Καλησπέρα σε όλους!
Βασίλη, Στα χρήσιμα του φόρουμ χρησιμοποιούμε δικά μας παραδείγματα.
Το παράδειγμα που ανέβασες, ναι λειτουργεί μόνο κάτω από συγκεκριμένες
συνθήκες.
Για παράδειγμα, η εντολή
Send δεν θα λειτουργήσει σωστά σε Outlook 2003
επειδή μπλοκάρεται από προειδοποιητικό μήνυμα ασφάλειας (δεν είναι ότι καλύτερο σε έναν αυτοματισμό) και χρειάζεται την κατάλληλη ενέργεια από τον χρήστη για να συνεχιστεί ο κώδικας.
Επίσης, ακόμα και αν αποσταλεί προγραμματιστικά (σε νεότερες εκδόσεις του Outlook ο περιορισμός απενεργοποιείται) δεν είναι σίγουρο ότι τα μηνύματα θα αποσταλούν άμεσα.
Δες ένα παράδειγμα κώδικα αποστολής Email (υπάρχει και στο συνημμένο) παρακάτω:
Τάσος
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal Hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private OL As Object
Sub MakeOLBinding()
' Δεν είναι απόλυτο ότι το Outlook θα στείλει τα μηνύματα που δημιουργούμε προγραμματιστικά
' Με την παρακάτω μέθοδο ανοίγουμε την εφαρμογή και μετά δημιουργούμε το αντικείμενο
' με τη μέθοδο GetObject().
' Έτσι, τα μηνύματα δεν θα παραμείνουν στο φάκελο "Outbox" αλλά θα αποσταλλούν άμεσα
' είτε αν ο χρήστης πατήσει "Αποστολή",
' είτε το μήνυμα αποσταλλεί προγραμματιστικά (Outlook > 2003 + oMail.Send)
Dim StartOL As Long
If FindWindow(vbNullString, "Microsoft Outlook") = 0 Then
StartOL = ShellExecute(0, "open", "outlook.exe", "", "", 3)
End If
On Error Resume Next
Do
If Err <> 0 Then Err.Clear
Set OL = GetObject(, "Outlook.Application")
If Not OL Is Nothing Then
OL.ActiveWindow.WindowState = 1
Exit Do
End If
Sleep 100
Loop
End Sub
Sub CheckForExpiryDates()
Dim strBody As String, strSubj As String, rng As Range
strSubj = "Το θέμα του μηνύματος ή τιμή από κάποιο κελί"
strBody = "Το κείμενο του μηνύματος ή τιμή από κάποιο κελί"
Set rng = Sheet1.Range("B2:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
If rng.Row > 1 Then
SendEmail rng, strSubj, strBody
End If
End Sub
Sub SendEmail(rngAddresses As Range, _
strSubj As String, _
strBody As String)
Dim oMail As Object, c As Range
For Each c In rngAddresses
DoEvents
If c.Offset(, 1) <= Date And c.Offset(, 2) <> "a" Then
If OL Is Nothing Then MakeOLBinding
Set oMail = OL.CreateItem(0&)
With oMail
.To = c.Text
.Subject = strSubj
.Body = strBody
On Error Resume Next
.Display
' Για εκδόσεις Outlook 2003 όπου η δυνατότητα άμεσης αποστολής (oMail.Send)
' μπλοκάρεται από προειδοποιητικό μήνυμα ασφάλειας.
' .Send ' Θα λειτουργήσει σε εκδόσεις Outlook νεότερες του 2003
' Όποιος θελήσει να στείλει E-Mail αυτόματα μέσω Outlook 2003 με τη μέθοδο της
' άμεσης αποστολής (oMail.Send), θα πρέπει να γράψει παρόμοιο κώδικα
' και στο Outlook (μόνο για προχωρημένους).
' Σε έκδοση Outlook 2003 Θα μπορούσε να λειτουργήσει μόνο σε περιβάλον Exchange
End With
If Err = 0 Then
c.Offset(, 2) = "a"
'c.Offset(, 2) = μια στήλη μορφοποιημένη με γραμματοσειρά "Marlett"
' όπου το "a" αυτής της γραμματοσειράς έχει τη μορφή ενός τικ και
'αποτελεί ένδειξη ότι το μήνυμα απεστάλη 'η τουλάχιστον δημιουργήθηκε.
Else
c.Offset(, 2) = "r"
Err.Clear
End If
End If
Next
If Not OL Is Nothing Then Set OL = Nothing
End Sub