Makro Email mit Anhang versenden

Computer: Software & Programmierung Visual Basic
#1

Hallo,
ich möchte in Excel ein Makro erstellen, mit dem ich per Knopfdruck mehrere Emails mit unterschiedlichen Anhängen an unterschiedliche Empfänger via Outlook versenden kann.
Das Makro soll sich aus der Excel-Tabelle folgende Variablen holen:
Spalte A: Empfänger-Emailadressen
Spalte B: Betreff
Spalte C: Text (wenn möglich mehrzeilig mit Absatz)
Spalte D: Pfad der pdf-Datei, die als Email-Anhang mitgeschickt werden soll (es sollten mehrere Dateien als Anhang einer Email mitgeschickt werden können)

Ist sowas möglich?
Falls ja, schon mal vielen Dank für Lösungsvorschläge!
Viele Grüße
Andrea

#2

Spalte A: Empfänger-Emailadressen
Spalte B: Betreff
Spalte C: Text (wenn möglich mehrzeilig mit Absatz)
Spalte D: Pfad der pdf-Datei, die als Email-Anhang
mitgeschickt werden soll (es sollten mehrere Dateien als
Anhang einer Email mitgeschickt werden können)

Hallo Andrea,

zu D, stehen die alle in D, wodurch getrennt? oder auch in E,F usw.?
Im Beispielcode wird 3mal die gleiche Datei angehängt.
Zum Testen kannste ja mit Display anstatt Send arbeiten.

Sub Verteilen()
 Dim oOL As Object
 Dim oOLMsg As Object
 Dim oOLRecip As Object
 Dim oOLAttach As Object
 Dim iRow As Integer, iCounter As Integer
 Dim sFile As String, sRec As String, sSub As String
 Dim sBody As String
 Dim bln
 Application.ScreenUpdating = False
 Application.DisplayStatusBar = True
 bln = Application.DisplayStatusBar
 iRow = Cells(Rows.Count, 1).End(xlUp).Row
 Set oOL = CreateObject("Outlook.Application")
 For iCounter = 2 To iRow
 sRec = Cells(iCounter, 1) 'Empfänger
 sFile = Cells(iCounter, 4) 'Anlage
 sSub = Cells(iCounter, 2) 'Betreff
 sBody = Cells(iCounter, 3) 'Text
 Application.StatusBar = "Sende Datei " & sFile & " an " & sRec & "..."
 Set oOLMsg = oOL.CreateItem(0)
 With oOLMsg
 Set oOLRecip = .Recipients.Add(sRec)
 .Subject = sSub
 .Body = sBody & vbLf & vbLf
 'Set oOLAttach = .Attachments.Add(sFile)
 .Attachments.Add sFile
 .Attachments.Add sFile
 .Attachments.Add sFile
 '.display
 .Send
 End With
 oOLRecip.Resolve
 Next iCounter
 Set oOL = Nothing
 Application.StatusBar = False
 Application.DisplayStatusBar = bln
End Sub

Gruß
Reinhard

#3

Hallo Reinhard,
vielen Dank, das ist genau das was ich brauch :smile:

Zu D:
Die werden durch ; getrennt.
Falls es allerdings einfacher ist, wäre auch E, F, etc möglich.

Was muss ich denn im Code ändern, damit die Anhänge richtig mitgeschickt werden?

Vielen Dank!
Andrea

#4

Hallo Andrea,

vielen Dank, das ist genau das was ich brauch :smile:

für so Fälle darfste besternen :smile:))

Die werden durch ; getrennt.
Falls es allerdings einfacher ist, wäre auch E, F, etc
möglich.

Ist prinzipiell egal, ich muß nur wissen wie und wo sie stehen, im Code habe ich als Trennungszeichen das „;“ genommen.

Wenn man 500.000 Dateien per Vba ausliest ist es ja ganz nett wenn unten in der Statusbar angezeigt wird „Bin bei datei 213.567 / 500.000“, daran kann man dann quasi sehen ob der Code noch läuft.
Aber bei kleinen mengen wie Emaildaten an Outlook zu schicken, lohnt sich das meist nicht.

Wenn du das nicht brauchst, so werfe alle Zeilen raus wo Statusbar in der Codezeile vorkommt.

Sub Verteilen()
 Dim oOL As Object
 Dim oOLMsg As Object
 Dim oOLRecip As Object
 Dim oOLAttach As Object
 Dim iRow As Integer, iCounter As Integer
 Dim sFile, sRec As String, sSub As String
 Dim sBody As String
 Dim bln, S
 Application.ScreenUpdating = False
 Application.DisplayStatusBar = True
 bln = Application.DisplayStatusBar
 iRow = Cells(Rows.Count, 1).End(xlUp).Row
 Set oOL = CreateObject("Outlook.Application")
 For iCounter = 2 To iRow
 sRec = Cells(iCounter, 1) 'Empfänger
 sFile = Split(Cells(iCounter, 4), ";") 'Anlage
 sSub = Cells(iCounter, 2) 'Betreff
 sBody = Cells(iCounter, 3) 'Text
 Application.StatusBar = "Sende Datei " & sFile(0) & " an " & sRec & "..."
 Set oOLMsg = oOL.CreateItem(0)
 With oOLMsg
 Set oOLRecip = .Recipients.Add(sRec)
 .Subject = sSub
 .Body = sBody & vbLf & vbLf
 For S = 0 To UBound(sFile)
 .Attachments.Add sFile(S)
 Next S
 '.display
 .Send
 End With
 oOLRecip.Resolve
 Next iCounter
 Set oOL = Nothing
 Application.StatusBar = False
 Application.DisplayStatusBar = bln
End Sub

Gruß
Reinhard

1 Like
#5

Hallo Reinhard,
VIELEN DANK!!!
Viele Grüße
Andrea