ich sitze schon eine ganze Weile an meinem Problem und schaffe es nicht.
Nachstehenden Code habe ich vor einiger Zeit hier im Forum gefunden. Funzt auch echt super gut. In diesem Code wird in Zelle F2 der Pfad und der Dateiname einer Datei angegeben, die als Anlage allen Mails mitgegeben wird.
Ich möchte aber gerne (da ich immer nur 3 Mails sende) das ich pro Mail jeweils eine eigene Datei als Anhang sende. Also müsste ich in F1, in F2 und in F3 jeweils einen Pfad angeben können der dann für die jeweils zugehörige Mail gedacht ist.
Ich hoffe das ist verständlich ausgedrückt.
'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 3) 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 Serienmail_mit_Anlagen()
'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 = 3 'Hier wird die Anzahl der zu sendenden Empfänger (Zeilen) eingetragen
'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 : F2
For y = 2 To 2
'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
Danke im voraus für Eure Hilfe.
Gruß
Claudia