Excel – Serienmail mit Anhängen

Serienmails können über Word / Outlook leider nur ohne Anhänge verschickt werden. Warum also nicht die Serienmail über Excel starten und so beliebig Anhänge mitschicken?

Hier ist der Code:
Option Explicit

Sub Excel_Serial_Mail()
'Andreas Thehos
'http://thehosblog.com

Dim objOLOutlook As Object
Dim objOLMail As Object
Dim lngMailNr As Long
Dim lngZaehler As Long
Dim strAttachmentPfad1 As String, strAttachmentPfad2 As String
Dim strSignatur As String

On Error GoTo ErrorHandler

Set objOLOutlook = CreateObject("Outlook.Application")
lngMailNr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'strAttachmentPfad1 = "C:\Users\Andreas\Documents\Spenden Kinder-Tafel.docx"
'strAttachmentPfad2 = "C:\Users\Andreas\Documents\YouTube\YouTube 2.jpg"
'Hier Pfade und Dateien anpassen

For lngZaehler = 2 To lngMailNr
If Cells(lngZaehler, 1) "" Then
Set objOLMail = objOLOutlook.CreateItem(olMailItem)
With objOLMail
.To = Cells(lngZaehler, 1)
.CC = ""
.BCC = ""
.GetInspector.Activate
strSignatur = .Body
.Sensitivity = 3
.Importance = 2
.Subject = "Vorgabe Wochenplan"
.BodyFormat = olFormatPlain
.Body = "Hallo " & Cells(lngZaehler, 3) & "," & vbCrLf & _
Cells(lngZaehler, 2).Value & " ist die Zahl des Tages." & vbCrLf & strSignatur

'Hier anpassen
'.Attachments.Add strAttachmentPfad1
'.Attachments.Add strAttachmentPfad2
.Display
.Send
'.Display
End With
Set objOLMail = Nothing
End If
Next lngZaehler
Set objOLOutlook = Nothing

Exit Sub

ErrorHandler:
MsgBox Err.Number & " " & Err.Description & " " & Err.Source, _
vbInformation, "Ein Fehler ist aufgetreten"
Exit Sub
End Sub

Hier ist die Datei:
http://1drv.ms/1kgYEx0

Hier geht es zum Video:

Videolink: http://youtu.be/i-gvQQ0749Y

Ein Kommentar

  1. Marcel

    Hallo gibt es zufällig eine Möglichkeit das mit Excel 2010 und Mozilla Thunderbird zu realisieren?

    Mfg