AW: Dynamischer eMail Versand aus Excel heraus
Jens
Hallo Tibu!
Ich habe hier was aus meiner Sammlung; müsstest es etwas anpassen:
Grüße,
Jens
========================================================================================
In diesem Beispiel stehen in der aktiven Tabelle in A1 bis A10 E-Mail-Adressen ( deshalb die Schleife von 1 bis 10 )
Sub Excel_Serienmail_via_Outlook_Senden()
Dim OutApp As Object, Mail As Object
Dim i As Integer
Dim Nachricht
For i = 1 To 10
'Variablen müssen bei jeder Schleife neu initalisiert werden
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Cells(i, 1)'Adresse
.Subject = Cells(i, 2) 'Betreffzeile
.Body = Cells(i, 3) 'Sendetext
'Hier wird die Mail zuerst angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
'Variablen zurücksetzen sonst geht es nicht
Set OutApp = Nothing 'CreateObject("Outlook.Application")
Set Nachricht = Nothing 'OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub
Serienmail mit verschiedenen Attachments aus einer Tabelle mit Outlook senden
Ein ähnliches Beispiel wie oben mit dem Unterschied, dass die Empfänger in den Zellen stehen und
die jeweiligen Attachments ( in diesem Fall 10 ) stehen inclusive Pfad in den Zellen F2:F10
die jeweiligen Attachments mit den Pfadangaben in den Nachbarzellen.
In diesem Beispiel wird das FileSystemObject zu Hilfe genommen um die Ordner bzw. die Dateien auf Existenz zu testen.
Das ganze könnte auch etwas einfacher gelöst werden, aber so kann das FS-Object wunderbar gezeigt werden.
Sub Excel_Serienmail_mit_mehreren_Anlagen_via_Outlook_Senden()
'Variablendefinition
Dim fs As Object, F As Object
Dim OutApp As Object, Mail As Object
Dim i As Integer, y As Integer, Msg As Integer
Dim Nachricht As Variant
Dim AWS As String
Dim AnzEmpfänger As Integer
'Variablen füllen
'Filesystemobjekt erstellen
Set fs = CreateObject("Scripting.FileSystemObject")
'Hier die Anzahl Empfänger definieren
'Kann auch ein Range auf der Tabelle sein
AnzEmpfänger = 10
'1. Fehlerprüfung
'Prüfen ob alle Inhalte vorhanden sind
'Wenn nicht wird das Makro abgebrochen
'In Spalte A steht der Name
'In Spalte B steht der Betreff
'In Spalte C steht der Text
For i = 1 To AnzEmpfänger
If Cells(i, 1) = "" Or Cells(i, 2) = "" Or Cells(i, 3) = "" Then
Msg = MsgBox("Unvollständige Angaben beim Empfänger in Zeile "_
& i, vbCritical + vbOKOnly, "Abbruch")
Exit Sub
End If
Next i
'2. Fehlerprüfung
'Mit dem FilesystemObjekt wird zuerst die Existenz
'der Dateien geprüft. Wenn eine nicht existiert
'wird das Makro abgebrochen
'Die Links auf deine Anlagen liegen im
'Bereich F2 : F10
For y = 2 To 10
'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen
'ohne weitere Fehlerprüfung
If Cells(y, 6) = "" Then Exit For
If fs.fileexists(Cells(y, 6)) = False Then
Msg = MsgBox("Die Datei: " & Cells(y, 6) & " in F" & y & " exitstiert nicht !"_
& vbCrLf & "Der Sendevorgang an; " & Cells(i, 1) & " wird abgebrochen!",_
vbCritical + vbOKOnly, "Dateifehler")
Exit Sub
End If
Next y
'Sendevorgang einleiten
For i = 1 To AnzEmpfänger
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Cells(i, 1) 'irgendwer@irgendein-provider.de
.Subject = Cells(i, 2) 'Betreffzeile
.Body = Cells(i, 3) 'Sendetext"
For y = 2 To 10
AWS = Cells(y, 6)
'Wenn die Zelle / Variable leer ist
'wird diese Schleife für die Attachments abgebrochen
If AWS = "" Then Exit For
.attachments.Add AWS
Next y
'Hier wird die Mail zuerst angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
'Variablen zurücksetzen
Set OutApp = Nothing
Set Nachricht = Nothing
'Warten auf Outlook :-))
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub