Excel Serienbrief VBA mit Standardtext und Anhang

Hallo Leute,

ich habe folgendes Problem:

Ich habe eine Excel Datei mit mehreren Mail Adressen.
Diese sollen alle eine Mail erhalten mit jeweils einem Standardtext und Standard Betreff.
Der Text und Betreff ist für alle Empfänger der gleiche.
Soweit so gut. Habe ich noch hinbekommen (zumindest an eine Adresse).
Nun soll jedem Empfänger (jeder Mail-Adresse) ein individueller Anhang (PDF) angehängt werden.
Dies übersteigt meine VBA Kenntnisse leider völligst.

Wie schicke ich die Mail an alle Adressen von Spalte AD2 bis AD_letzer Wert?
Wie verknüpfe ich jeweils eine PDF Datei mit einer der vorhandenen Mails?

Bisher sieht mein Skript folgt aus (funktioniert auch: schickt dem Empfänger aus AD213 eine Mail mit Text und Betreff und der angehängten Datei "Datei.txt"):


Sub LotusMail(Empfaenger As String, Dateianhang As String, Inhalt As String)
Dim Kopie_Empfänger As String, BlindKopie_Empfänger As String, Betreff As String

Const EMBED_ATTACHMENT = 1454
Dim server As String, mailfile As String
Dim session As Object
Dim DB As Object
Dim doc As Object
Dim rtitem As Object
Dim EmbeddedObject As Object

' Auslesen der Mail-DB
Set session = CreateObject("Notes.NotesSession")
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set DB = session.GETDATABASE(server, mailfile)
Set doc = DB.CreateDocument()
doc.Form = "Main Topic"
doc.SendTo = Empfaenger ' Adressaten übergeben
' doc.CopyTo = Me.Kopie_Empfänger.Value
' doc.BlindCopyTo = Me.BlindKopie_Empfänger.Value
doc.Subject = "Standardbetreff!" ' Betreff hier festlegen
doc.Body = Inhalt
Dateianhang = "C:\Datei.txt"
Set rtitem = doc.CREATERICHTEXTITEM("ProjectDescription")
Set EmbeddedObject = rtitem.EMBEDOBJECT(EMBED_ATTACHMENT, "", Dateianhang) 'Dateianhang mit Pfad und Dateiname überschreiben
'doc.SIGN = "0"
'doc.ENCRYPT = "0"
'doc.BlindCopyTo = ""
'doc.DefaultMailSaveOptions = 0 '"1"
'doc.MailSaveOptions = 0 '"1"
'doc.DeliveryReport = "B"
'doc.MailOptions = "2" '"0"/*-*--*//**/
'doc.Importance = "1" ' Neu
'doc.logo = "Barmenia" 'neu
'doc.ReturnReceipt = "1"
doc.principal = session.UserName
doc.viewicon = "75"
doc.FROM = session.UserName ' Von Zeile = Aktueller Benutzer
' doc.SaveOptions = 0 '"1"
' doc.SecureMail = ""
' doc.SenderTag = "F"

'SMTP-Originator
doc.PostedDate = Format$(Now, "dd.mm.yyyy") + " " + Format$(Now, "hh:nn:ss")
' doc.SAVEMESSAGEONSEND = 0
' Call doc.Save(False, False)
Call doc.Send(True, "")
Set doc = Nothing
Set DB = Nothing
End Sub

Sub Mail_Senden()
Dim Cell As Range
Call LotusMail(Range("AD213"), "", "Standardtext")

'Für jede Zelle in Bereich d2 bis zur letzen belegten Zelle in Spalte d wird eine Mail versandt.
' For Each Cell In Range("AD213:AD" & Cells(Rows.Count, "AD").End(xlUp).Row)
' If Cell <> "" Then Call LotusMail(Cell.Value, "", Cell(1, -2) & " " & Cell(1, -1) & " " & Cell(1, 0) & "," & Range("g2").Text & Cell(1, 2) & Range("h2").Text)
' Next
End Sub

Gibt es für so eine Anwendung evtl. auch Freeware?


Grüße

xfiles

Sub LotusMail(ByVal Empfaenger As String, ByVal Dateianhang As String, ByVal Betreff As String, ByVal Inhalt As String)

    Dim Kopie_Empfänger As String, BlindKopie_Empfänger As String
    
    Const EMBED_ATTACHMENT = 1454
    Dim server As String, mailfile As String
    Dim session As Object
    Dim DB As Object
    Dim doc As Object
    Dim rtitem As Object
    Dim EmbeddedObject As Object
    
    ' Auslesen der Mail-DB  
    Set session = CreateObject("Notes.NotesSession")  
    server = session.GetEnvironmentString("MailServer", True)  
    mailfile = session.GetEnvironmentString("MailFile", True)  
    Set DB = session.GETDATABASE(server, mailfile)
    Set doc = DB.CreateDocument()
    doc.Form = "Main Topic"  
    doc.SendTo = Empfaenger ' Adressaten übergeben  
    ' doc.CopyTo = Me.Kopie_Empfänger.Value  
    ' doc.BlindCopyTo = Me.BlindKopie_Empfänger.Value  
    doc.Subject = Betreff
    doc.Body = Inhalt
    Set rtitem = doc.CREATERICHTEXTITEM("ProjectDescription")  
    Set EmbeddedObject = rtitem.EMBEDOBJECT(EMBED_ATTACHMENT, "", Dateianhang) 'Dateianhang mit Pfad und Dateiname überschreiben  
    'doc.SIGN = "0"  
    'doc.ENCRYPT = "0"  
    'doc.BlindCopyTo = ""  
    'doc.DefaultMailSaveOptions = 0 '"1"  
    'doc.MailSaveOptions = 0 '"1"  
    'doc.DeliveryReport = "B"  
    'doc.MailOptions = "2" '"0"/*-*--*//**/  
    'doc.Importance = "1" ' Neu  
    'doc.logo = "Barmenia" 'neu  
    'doc.ReturnReceipt = "1"  
    doc.principal = session.UserName
    doc.viewicon = "75"  
    doc.FROM = session.UserName ' Von Zeile = Aktueller Benutzer  
    ' doc.SaveOptions = 0 '"1"  
    ' doc.SecureMail = ""  
    ' doc.SenderTag = "F"  
    
    'SMTP-Originator  
    doc.PostedDate = Format$(Now, "dd.mm.yyyy") + " " + Format$(Now, "hh:nn:ss")  
    ' doc.SAVEMESSAGEONSEND = 0  
    ' Call doc.Save(False, False)  
    Call doc.Send(True, "")  
    Set doc = Nothing
    Set DB = Nothing
End Sub

Sub Mail_Senden()
    Dim sheet As Worksheet, rngStart As Range, rngEnd As Range, cell As Range
    Set sheet = Worksheets("Tabelle1")  
    Set rngStart = sheet.Range("AD2")  
    Set rngEnd = rngStart.End(xlDown)
    For Each cell In Range(rngStart, rngEnd)
        If cell.Value <> "" Then  
            Anhang = cell.Offset(0, 1).Value
            LotusMail cell.Value, Anhang, "Standardbetreff!", "Standardbody"  
        End If
    Next
End Sub

Anhang = cell.Offset(0, 1).Value