AW: eMail aus Excel versenden wie geht das ?
Ramses
Hallo Andreas
ich habe hier noch was ausgegraben
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
AnzEmpfänger = 10
'1. Fehlerprüfung
'Prüfen ob alle Inhalte vorhanden sind
'Wenn nicht wird das Makro abgebrochen
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 Header"
.Body = Cells(i, 3) '"Sendetext"
For Y = 2 To 10
AWS = Cells(Y, 6)
'Wenn die Zelle / Variable leer ist
'wird diese Schleife 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 'CreateObject("Outlook.Application")
Set Nachricht = Nothing 'OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:02"))
Next i
End Sub
Die Adresse steht in Spalte A, der Betreff in Spalte B und der Text in Spalte C.
Die zu sendende Datei mit Pfadangabe in Spalte F.
Das Attachment kannst du aber auch so definieren
AWS = ThisWorkbook.Fullname
Wenn es die aktuelle Mappe ist, die versendet werden soll.
Viel Spass beim ausprobieren ;-))
Gruss Rainer