Serien-E-Mails mit individuellen Anhängen über Outlook versenden

In diesem Blogbeitrag werde ich einen Makro-Code für Microsoft Office vorstellen, der es ermöglichen soll, Serien-E-Mails mit individuellen Anhängen zu versenden. Was man dazu braucht, ist ein Word-Dokument, eine Excel-Liste und Outlook.

1.

Als erstes brauchst du eine Excel-Liste, welche die nötigen Informationen enthält. Das Makro bezieht die nötigen Daten nämlich aus dieser Tabelle. Was dort enthalten sein muss, sind ein paar Spalten mit der Anrede, den Vor- und Nachnamen, die E-Mail-Adresse, der E-Mail-Betreff und der Pfad zum Anhang. Wem es zu anstrengend ist, den Dateipfad zu aufzuschreiben, kann auf einen kleinen Trick zurückgreifen. Gehe zu dem Reiter „Einfügen“ und wähle ganz rechts „Objekt“ (steht neben Kopf- und Fußzeile) aus. Im neuen Fenster klickst du dann auf „Aus Datei erstellen“ und dann auf „Durchsuchen“. Nun wählst du ganz einfach die gewünschte Datei aus. Klickt auf „Auswählen“. Danach wird dir in der Zeile neben „Durchsuchen“ der Pfad zur Datei angezeigt. Den kannst du kopieren und in die entsprechende Zelle legen.

Wenn die Anhänge zum Beispiel aus den Vor- und Nachnamen der jeweiligen Person in der Zeile bestehen, könntest du auch mit Hilfe einer Excel-Formel einen Pfad generieren lassen. Das ist dann nützlich, wenn dies bei den restlichen Datensätzen genau dasselbe Schema ist. Eine Formel könnte dann so aussehen:

=“D:\Dokumente\“&D2&“_““C2&“.pdf“

Diese könnte man dann auf die folgenden Zellen anwenden und so schnell kann man die Dateipfade erstellen. Sollte es ein generischer Dateiname sein, nur die Nummer ist jeweils fortlaufend, dann kann man den Dateipfad auch einmal in eine Zelle schreiben und die Zelle dann auf die anderen Zellen automatisch damit ausfüllen lassen.

Es ist auch möglich, mehrere Datein an die E-Mail anzuhängen. Dafür sollten die Dokumentenpfade in einer Zelle hintereinander, getrennt durch ein Komma, folgen. Es sollte also bspw. so aussehen: D:/Dokumente/Test1.pdf,D:/Dokumente/Test2.pdf
Bei diesem Code müssen allerdings nicht zwingend mehrere Dateien angehängt werden. Auch ein Anhang wird berücksichtigt und versendet.

Wir arbeiten mit diesen einfachen Daten, da dies in der Regel ausreichen dürfte. Wer mehr als diese Daten für die E-Mail braucht oder mehr als einen individuellen Anhang hat, müsste den später folgenden Code anpassen.

Wichtig ist, dass dieses Arbeitsblatt an erster Stelle kommt. Solltest du also eine Excel-Datei mit mehreren Arbeitsblättern haben, so verschiebe das Blatt mit den Daten an Position 1.

2.

Danach kannst du deinen E-Mail-Text in Word schreiben. Wichtig zu beachten ist, dass wir nicht mit der Sendungs-Funktion in Word arbeiten. Seriendruckfelder bzw. Platzhalter werden also nicht über diese Funktion eingefügt, sondern als Text und zwar wie folgt: Nehmen wir an, wir wollen die Grußformel schreiben, dann schreiben wir folgendes:

%Anrede% %Titel% %Vorname% %Nachname%,

wir freuen uns, Ihnen bekannt geben zu dürfen …

Diese Platzhalter werden später durch das Makro für jede E-Mail individuell anhand der Excel-Liste ersetzt. Da hier davon ausgegangen wird, dass die geläufige Grußformel „Sehr geehrte/r“ benutzt wird, wird diese Floskel, natürlich an das Geschlecht angepasst, im Feld %Anrede% mit eingefügt.

Es ist außerdem auch kein Problem, Zeichenketten fett, kursiv oder unterstrichen etc. zu setzen. Auch Hyperlinks werden übernommen. Bilder werden allerdings nicht übernommen!

3.

Jetzt kommt der spannende Teil: Das Makro muss in die Word-Datei eingefügt und ausgeführt werden. Im Folgenden erkläre ich, wie man dies bewerkstelligt.

Um ein VBA-Makro in Word einzufügen, musst du zunächst den Reiter „Entwicklertools“ zum Menü hinzufügen. Das geht so:

Klicke auf die Registerkarte „Datei“ und dann auf „Optionen“.
Wähle im Dialogfeld „Word-Optionen“ die Kategorie „Menüband anpassen“ aus.
Aktiviere im rechten Bereich unter „Hauptregisterkarten“ das Kontrollkästchen „Entwicklertools“.
Klicke auf „OK“. Nun siehst du den Reiter „Entwicklertools“ im Menü.

Für eine bebilderte Anleitung kannst du auch die folgende Webseite aufrufen, die das bereits sehr gut dargelegt hat: https://www.tecchannel.de/a/entwicklertools-aktivieren,3278588

Sodann kommen wir zum nächsten Schritt. Um ein VBA-Makro zu erstellen oder einzufügen, musst du den Visual Basic-Editor öffnen:

Klicke auf diese Schaltfläche und es müsste sich ein neues großes Fenster mit dem Titel „Microsoft Visual Basic for Applications“ öffnen. Gehe dann oben auf „Einfügen“ und dann auf „Modul“.

Danach öffnet sich wieder ein neues Fenster und dort fügst du nun folgenden Code ein, den du unter dem GitHub-Button findest (Achtung: Dieser Code versendet alle E-Mails automatisch, das heißt es ist keine Einflussnahme mehr auf die E-Mails möglich. Wenn das nicht gewünscht ist, dann sollte eine Code-Variation vom unteren Teil der Seite genommen werden. Alle Codes befinden sich dort außerdem zum Download.):

Hier geht es zum Code:

Puh, das wird wahrscheinlich jeden erschlagen, der das zum ersten Mal sieht.

Hast du den Code eingefügt, fehlt noch eine kleine Sache. Und zwar gehst du oben auf „Extras“ und dann zu „Verweise“. In der Liste muss auf jeden Fall „Microsoft Excel 16.0 Object Library“, „Microsoft Word 16.0 Object Library“ und „Microsoft Office 16.0 Object Library“ durch einen Haken aktiviert sein. Wenn nicht, durchsuche die Liste nach dem Verweis.

Oben stehen die aktivierten Verweise. Word, Excel und Office Objekt-Verweis muss aktiviert sein

In der langen Liste befinden sich die Verweise, wenn sie noch nicht aktiviert sind

Zurück

Weiter

Ist das auch getan, bist du eigentlich soweit, um das Makro zu aktivieren. Dafür kannst du im VBA-Editor auf den grünen Abspiel-Button oben in der Leiste klicken. Sodass öffnet sich zunächst der Datei-Manager und dort musst du die Excel-Liste auswählen. Danach musst du in den Abfrage-Fenstern den Buchstaben der Spalte eingeben, wo die jeweils abgefragten Daten stehen. Das war es. Die E-Mails werden danach sofort versendet, d. h. ein vorheriges Überprüfen der generierten E-Mails ist nicht möglich. Allerdings habe ich für ein vorheriges Überprüfen und manuelles Versenden eine Code-Variation geschrieben, die unten auf der Seite angesehen werden können.

Es kann passieren, dass Fehler auftreten können. So kann bspw. ein Dateipfad nicht gültig sein. Das Programm sagt dir dann, an welcher Stelle dieser Fehler vorliegt, sodass du ihn berichtigen kannst. Das Programm beendet sich dann zunächst. Wenn die Fehler behoben sind, kannst du das Makro erneut beginnen lassen. Ich habe versucht, die Fehlermeldungen so genau wie möglich, aber auch nicht zu überfrachtet, zu schreiben.

Falls dir jedoch im VBA-Editor Fehler angezeigt werden, dann solltest du vielleicht einen Fachkundigen oder ChatGPT (in Kürze erläutert) fragen. Sollte jedoch bei der Stelle:
Set fd = Application.FileDialog(msoFileDialogFilePicker)
ein Fehler angezeigt werden, der sinngemäß lauten könnte „Objektverweis ungültig“, dann solltest du überprüfen, ob die Verweise, die ich oben genannt habe, aktiviert sind. Wenn dies so ist, dann sollte der PC neu gestartet werden. Das hat bei mir geholfen.
Ebenfalls kann es passieren, dass an der Stelle:
lastRow = xlWS.Cells(Rows.Count, 1).End(xlUp).Row
eine Fehlermeldung angezeigt wird. In dem Fall klickst du bei der Fehlermeldung auf „Beenden“ und drückst nochmal auf den Abspiel-Button. Dann sollte der Code richtig laufen.

Wichtig zu erwähnen ist, dass dieser Code für meinen Anwendungsfall funktioniert hat. Allerdings könnte es für deine Bedürfnisse eben nicht genau passen. Es gibt aber Tools, die dir bei sowas sehr gut helfen können. ChatGPT ist eine KI, die Spracheingaben höchst präzise verarbeiten kann und auf Befehle, Fragen etc. sehr gut antwortet. Auch Code-Anpassungen sind mit ihr möglich. Du könntest also dort den Code eingeben und dazu darum bitten, den Code an deine jeweiligen Wünsche anzupassen. Ein paar Variationen des Codes habe ich allerdings unter auf der Seite mitveröffentlicht.

Wenn du dieses Makro in jedem deiner Dokumente verwenden willst, musst du im VBA-Editor links oben auf das Plus bei „Normal“ klicken, die dann ebenfalls bei dem darunter befindlichen Ordner und dann „This Document“ anklicken. Danach kannst du, wie oben beschrieben, über „Einfügen“ „Modul“ den Code einfügen.

Möchtest du nur dieses Dokument mit dem Makro abspeichern, dann musst du darauf achten, dass das Dokument als .docm-Datei (Word mit Makro-Datei) gespeichert wird.

Code-Variationen:

Standardmäßig beginnt der Code ab Zeile 2 der Excel-Liste die Datensätze zu extrahieren. Wenn es jedoch früher oder später beginnt, dann muss man im o. g. Code eine Änderung vornehmen. Im folgendem Code wurde noch eine InputBox hinzugefügt, welche die Anfangszeile abfragt und damit weiterarbeitet:

Sub SendEmailsFromWordWithExcelWithAbfrage()
Dim objOutlook As Object
Dim objMail As Object
Dim doc As Document
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim Pfad As Variant
Dim fd As Office.FileDialog
Dim objUndo As UndoRecord
Set objUndo = Application.UndoRecord

' Wähle die Excel-Datei aus. Der Dateipfad wird dann für den weiteren Cod zwischengespeichert.
Set xlApp = New Excel.Application
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .Title = "Excel-Liste auswählen"
    .Filters.Clear
    .Filters.Add "Excel-Dateien", "*.xl*"
    .AllowMultiSelect = False
    .ButtonName = "Auswählen"
    If .Show = -1 Then
        Pfad = .SelectedItems(1)
        Set xlWB = xlApp.Workbooks.Open(Pfad)
        Set xlWS = xlWB.Sheets(1)
        ' Hier kommt der Code, der ausgeführt wird, wenn der Benutzer eine Datei ausgewählt hat.
        ' Outlook wird geöffnet
        Set objOutlook = CreateObject("Outlook.Application")

        ' Das aktuell geöffnete und aktive Word-Dokument wird herangezogen
        Set doc = ActiveDocument
        
        
        'Nun folgt die Abfrage, in welcher Spalte die einzelnen Daten stehen
        Dim AnredeRange As Excel.Range
        Set AnredeRange = xlWS.Range("A1:Z10").Find("Anrede", LookIn:=xlValues, LookAt:=xlWhole)

        If Not AnredeRange Is Nothing Then
        'Die Anrede-Spalte ist in der gefundenen Zelle
        SpalteAnrede = Chr(AnredeRange.Cells.Column + 64)
        Else
        'Die Anrede-Spalte wurde nicht gefunden
        SpalteAnrede = InputBox("Geben Sie den Spaltenbuchstaben für die Anrede ein (z. B. A):")
            If SpalteAnrede = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub
            End If
            End If
        End If

        Dim TitelRange As Excel.Range
        Set TitelRange = xlWS.Cells.Find("Titel", LookIn:=xlValues, LookAt:=xlWhole)

        If Not TitelRange Is Nothing Then
        SpalteTitel = Chr(TitelRange.Cells.Column + 64)
        Else
        SpalteTitel = InputBox("Geben Sie den Spaltenbuchstaben für den Titel ein (z. B. B):")
            If SpalteTitel = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub
            End If
            End If
        End If

        Dim VornameRange As Excel.Range
        Set VornameRange = xlWS.Cells.Find("Vorname", LookIn:=xlValues, LookAt:=xlWhole)

        If Not VornameRange Is Nothing Then
        SpalteVorname = Chr(VornameRange.Cells.Column + 64)
        Else
        SpalteVorname = InputBox("Geben Sie den Spaltenbuchstaben für den Vornamen ein (z. B. C):")
            If SpalteVorname = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub
            End If
            End If
        End If

        Dim NachnameRange As Excel.Range
        Set NachnameRange = xlWS.Cells.Find("Nachname", LookIn:=xlValues, LookAt:=xlWhole)

        If Not NachnameRange Is Nothing Then
        SpalteNachname = Chr(NachnameRange.Cells.Column + 64)
        Else
        SpalteNachname = InputBox("Geben Sie den Spaltenbuchstaben für den Nachnamen ein:")
            If SpalteNachname = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub
            End If
            End If
        End If

        
        ' Suchbegriffe definieren
        Suchbegriffe = Array("E-Mail", "email", "e-Mail", "e-mail")

        ' Nach jedem Suchbegriff suchen
        For s = LBound(Suchbegriffe) To UBound(Suchbegriffe)
            Dim ToRange As Excel.Range
            Set ToRange = xlWS.Cells.Find(Suchbegriffe(s), LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not ToRange Is Nothing Then
                SpalteTo = Chr(ToRange.Cells.Column + 64)
                Exit For
            End If
        Next s

        ' Wenn keine Übereinstimmung gefunden wurde, benutze InputBox
        If ToRange Is Nothing Then
            SpalteTo = InputBox("Geben Sie den Spaltenbuchstaben für die Empfängeradresse ein:")
            If SpalteTo = "" Then
                If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
                    ' Aufräumen
                    Set objMail = Nothing
                    Set objOutlook = Nothing
                    ' Close the Excel file
                    xlWB.Close SaveChanges:=False
                    xlApp.Quit
                    Set xlWS = Nothing
                    Set xlWB = Nothing
                    Set xlApp = Nothing
                    Set Pfad = Nothing
                    Exit Sub
                End If
            End If
        End If

        
        Dim BetreffRange As Excel.Range
        Set BetreffRange = xlWS.Cells.Find("Betreff", LookIn:=xlValues, LookAt:=xlWhole)

        If Not BetreffRange Is Nothing Then
        SpalteSubj = Chr(BetreffRange.Cells.Column + 64)
        Else
        SpalteSubj = InputBox("Geben Sie den Spaltenbuchstaben für den Betreff ein:")
            If SpalteSubj = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub
            End If
            End If
        End If

        Dim Suchbegriffe2 As Variant
        Dim t As Integer
        ' Suchbegriffe definieren
        Suchbegriffe2 = Array("Anhang", "Anhänge")
        
        Dim AnhangGefunden As Boolean
        AnhangGefunden = False

        ' Nach jedem Suchbegriff suchen
        For t = LBound(Suchbegriffe2) To UBound(Suchbegriffe2)
            Dim AnhangRange As Excel.Range
            Set AnhangRange = xlWS.Cells.Find(Suchbegriffe2(t), LookIn:=xlValues, LookAt:=xlWhole)

            If Not AnhangRange Is Nothing Then
                SpalteAttach = Chr(AnhangRange.Cells.Column + 64)
                AnhangGefunden = True
                Exit For
            End If
        Next t

        If Not AnhangGefunden Then
            SpalteAttach = InputBox("Geben Sie den Spaltenbuchstaben für den Anhang ein:")
            If SpalteAttach = "" Then
                If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
                    ' Aufräumen
                    Set objMail = Nothing
                    Set objOutlook = Nothing
                    ' Close the Excel file
                    xlWB.Close SaveChanges:=False
                    xlApp.Quit
                    Set xlWS = Nothing
                    Set xlWB = Nothing
                    Set xlApp = Nothing
                    Set Pfad = Nothing
                    Exit Sub
                End If
            End If
        End If
        
        Anfangszeile = InputBox("Geben Sie die Zeilennummer an, ab welcher die Datensätze enthalten sind:")
        If Anfangszeile = "" Then
            If MsgBox("Möchten Sie den Vorgang abbrechen?", vbYesNo) = vbYes Then
            Exit Sub
            End If
        End If

        
        Dim Einverstanden As VbMsgBoxResult
        Einverstanden = vbNo
        Do While Einverstanden = vbNo ' Schleife, um die Eingabe zu wiederholen, falls der Benutzer nicht einverstanden ist
        ' Zeige die MsgBox mit den Datengruppen und Spaltenzuordnungen an
        Dim msg As String
        msg = "Folgende Datengruppen wurden gefunden:" & vbNewLine & _
          "Anrede: " & SpalteAnrede & vbNewLine & _
          "Titel: " & SpalteTitel & vbNewLine & _
          "Vorname: " & SpalteVorname & vbNewLine & _
          "Nachname: " & SpalteNachname & vbNewLine & _
          "E-Mail: " & SpalteTo & vbNewLine & _
          "Betreff: " & SpalteSubj & vbNewLine & _
          "Anhang: " & SpalteAttach & vbNewLine & vbNewLine & _
          "Anfangszeile: " & Anfangszeile & vbNewLine & vbNewLine & _
          "Sind Sie mit den ausgewählten Spalten und der Anfangszeile einverstanden?"
        Einverstanden = MsgBox(msg, vbQuestion + vbYesNoCancel, "Spalten der Datengruppen und Anfangszeile")
        ' Falls der Benutzer nicht einverstanden ist, frage nach der Spalte, die korrigiert werden soll
        If Einverstanden = vbNo Then
        Dim Datengruppe As String
        Datengruppe = InputBox("Bitte wählen Sie die Datengruppe aus, die nicht korrekt zugeordnet ist:" & vbNewLine & _
                              "Anrede, Titel, Vorname, Nachname, E-Mail, Betreff, Anhang")

        ' Weise der ausgewählten Datengruppe die korrekte Spalte zu
        Select Case Datengruppe
            Case "Anrede"
                SpalteAnrede = InputBox("Bitte geben Sie die korrekte Spalte für Anrede ein:")
            Case "Titel"
                SpalteTitel = InputBox("Bitte geben Sie die korrekte Spalte für Titel ein:")
            Case "Vorname"
                SpalteVorname = InputBox("Bitte geben Sie die korrekte Spalte für Vorname ein:")
            Case "Nachname"
                SpalteNachname = InputBox("Bitte geben Sie die korrekte Spalte für Nachname ein:")
            Case "E-Mail"
                SpalteTo = InputBox("Bitte geben Sie die korrekte Spalte für Empfängeradresse ein:")
            Case "Betreff"
                SpalteSubj = InputBox("Bitte geben Sie die korrekte Spalte für für Betreff ein:")
            Case "Anhang"
                SpalteAttach = InputBox("Bitte geben sie die korrekte Spalte für den Anhang ein:")
            Case "Anfangszeile"
                Anfangszeile = InputBox("Bitte geben Sie die korrekte Anfangszeile ein:")
            End Select
        
        ElseIf Einverstanden = vbCancel Then
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
        Exit Sub 'Beende den Sub, wenn der Benutzer "Abbrechen" auswählt
        
        Else 'Benutzer ist einverstanden
            Einverstanden = False
        End If
        Loop


        ' Starte die Aktions-Aufzeichnung
        objUndo.StartCustomRecord ("VBA-Aktionen")
        
        ' Da der Text in HTML-Text umgewandelt werden muss, werden nun z. B. fettgedruckte Zeichen mit den jeweils
        ' passenden HTML-Tags umgeben, damit dies in der E-Mail korrekt dargestellt wird.
        Dim bRange As Range, iRange As Range, uRange As Range, supRange As Range, subRange As Range, smallRange As Range, bigRange As Range
        Set bRange = doc.Content
        Set iRange = doc.Content
        Set uRange = doc.Content
        Set supRange = doc.Content
        Set subRange = doc.Content
        Set smallRange = doc.Content
        Set bigRange = doc.Content

        ' Umschließe Hyperlinks mit den HTML-Tags
        Dim HL As hyperlink
        For Each HL In ActiveDocument.Hyperlinks
        HL.Range.Text = "<a href=""" & HL.Address & """>" & HL.Range.Text & "</a>"
        Next

        With bRange.Find
        .ClearFormatting
        .Font.Bold = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With iRange.Find
        .ClearFormatting
        .Font.Italic = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With uRange.Find
        .ClearFormatting
        .Font.Underline = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With supRange.Find
        .ClearFormatting
        .Font.Superscript = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With subRange.Find
        .ClearFormatting
        .Font.Subscript = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With smallRange.Find
        .ClearFormatting
        .Font.SmallCaps = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        With bigRange.Find
        .ClearFormatting
        .Font.AllCaps = True
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        End With

        Do While bRange.Find.Execute() Or iRange.Find.Execute() Or uRange.Find.Execute() Or supRange.Find.Execute() Or subRange.Find.Execute() Or smallRange.Find.Execute() Or bigRange.Find.Execute() 'Loop through all matches
        If bRange.Find.Found Then
            bRange.InsertBefore "<b>" 'Insert <b> before bold word
            bRange.InsertAfter "</b>" 'Insert </b> after bold word
            bRange.Collapse wdCollapseEnd 'Move to next match
        End If
       
        If iRange.Find.Found Then
            iRange.InsertBefore "<i>" 'Insert <i> before italicized word
            iRange.InsertAfter "</i>" 'Insert </i> after italicized word
            iRange.Collapse wdCollapseEnd 'Move to next match
        End If
       
        If uRange.Find.Found Then
            uRange.InsertBefore "<u>" 'Insert <u> before underlined word
            uRange.InsertAfter "</u>" 'Insert </u> after underlined word
            uRange.Collapse wdCollapseEnd
        End If
       
        If supRange.Find.Found Then
            supRange.InsertBefore "<sup>" 'Insert <sup> before superscript word
            supRange.InsertAfter "</sup>" 'Insert </sup> after superscript word
            supRange.Collapse wdCollapseEnd
        End If
       
        If subRange.Find.Found Then
            subRange.InsertBefore "<sub>" 'Insert <sub> before subscript word
            subRange.InsertAfter "</sub>" 'Insert </sub> after subscript word
            subRange.Collapse wdCollapseEnd
        End If
       
        If smallRange.Find.Found Then
            smallRange.InsertBefore "<small>" 'Insert <small> before small caps word
            smallRange.InsertAfter "</small>" 'Insert </small> after small caps word
            smallRange.Collapse wdCollapseEnd
        End If
       
        If bigRange.Find.Found Then
            bigRange.InsertBefore "<big>" 'Insert <big> before all caps word
            bigRange.InsertAfter "</big>" 'Insert </big> after all caps word
            bigRange.Collapse wdCollapseEnd
        End If
        Loop
           
        ' Ersetze Zeilenumbrüche mit dem passenden HTML-Tag
        doc.Content = Replace(doc.Content, vbCr, "<br><br>")
        doc.Content = Replace(doc.Content, vbLf, "<br>")

		Dim rngTo As Excel.Range, rngSubj As Excel.Range, rngAttach As Excel.Range
        Dim strTo As String, strSubj As String, strAttach As String, strBody As String
        Dim strAnrede As String, strVorname As String, strNachname As String, DateipfadCheck As String
        Dim lastRow As Long
        
        ' Nun folgt der Teil, in dem der erstellte E-Mail-Text mit den Daten aus der Excel-Tabelle ersetzt wird, bis keine ausgefüllt Zeile mehr vorhanden ist.
        lastRow = xlWS.Cells(Rows.Count, 1).End(xlUp).Row
        
        For d = Anfangszeile To lastRow
        strVorname = xlWS.Range(SpalteVorname & d).Value ' Wert in der Spalte mit dem Vornamen, aktuelle Zeile
        strNachname = xlWS.Range(SpalteNachname & d).Value ' Wert in der Spalte mit dem Nachnamen, aktuelle Zeile
        DateipfadCheck = xlWS.Range(SpalteAttach & d).Value ' Wert in der Spalte mit den Anhängen, aktuelle Zeile
        arrFileNames = Split(DateipfadCheck, ",") 'Trenne den Zellinhalt anhand eines Kommas
        
        ' Überprüfe, ob die Dokumentenpfade gültig sind
        Dim a As Long
        Dim fehlerListe As String
        For a = LBound(arrFileNames) To UBound(arrFileNames)
        If Dir(arrFileNames(a)) = "" Then
        fehlerMeldungAnhang = "Der Pfad zu " & arrFileNames(a) & " ist ungültig."
        fehlerListe = fehlerListe & "Datensatz " & strNachname & ", " & strVorname & ": " & fehlerMeldungAnhang & vbCrLf & "Bitte korrigieren Sie den Pfad bzw. Pfade und starten den Vorgang erneut. Es wurde keine E-Mail versendet."
        End If
        Next a
        Next d
        If fehlerListe <> "" Then
            MsgBox "Folgende Fehler wurden gefunden:" & vbCrLf & fehlerListe
            ActiveDocument.Undo
            ' Aufräumen
            Set objMail = Nothing
            Set objOutlook = Nothing
            ' Close the Excel file
            xlWB.Close SaveChanges:=False
            xlApp.Quit
            Set xlWS = Nothing
            Set xlWB = Nothing
            Set xlApp = Nothing
            Set Pfad = Nothing
            Exit Sub ' beende den Sub, falls Fehler gefunden wurden
        End If
        ' Wiederhole die Datenersetzung für jeden Datensatz
        
		For i = Anfangszeile To lastRow ' Schleife von Zeile 2 bis zur letzten Zeile
        strTo = xlWS.Range(SpalteTo & i).Value ' Wert in der Spalte mit den Empfängeradressen, aktuelle Zeile
        strSubj = xlWS.Range(SpalteSubj & i).Value ' Wert in der Spalte mit den Betreffzeilen, aktuelle Zeile
        strAnrede = xlWS.Range(SpalteAnrede & i).Value ' Wert in der Spalte mit der Anrede, aktuelle Zeile
        strTitel = xlWS.Range(SpalteTitel & i).Value ' Wert in der Spalte mit dem Titel, aktuelle Zeile
        strVorname = xlWS.Range(SpalteVorname & i).Value ' Wert in der Spalte mit dem Vornamen, aktuelle Zeile
        strNachname = xlWS.Range(SpalteNachname & i).Value ' Wert in der Spalte mit dem Nachnamen, aktuelle Zeile
        strAttach = xlWS.Range(SpalteAttach & i).Value ' Wert in der Spalte mit den Anhängen, aktuelle Zeile
        
        
       
         ' Überprüfe, ob die Anrede für jenes Geschlecht stimmt
        If strAnrede = "Frau" Then
            strAnrede = "Sehr geehrte Frau"
        ElseIf strAnrede = "Herr" Then
            strAnrede = "Sehr geehrter Herr"
        Else
            strAnrede = "" ' set an empty string if the value is neither "Frau" nor "Herr"
        End If
       
        ' Ersetze die Platzhalter mit den Daten aus der Excel-Liste
       
        strBody = Replace(doc.Content.Text, "%Anrede%", strAnrede)
        strBody = Replace(strBody, "%Titel%", strTitel)
        strBody = Replace(strBody, "%Vorname%", strVorname)
        strBody = Replace(strBody, "%Nachname%", strNachname)
       
     
        ' Öffne eine neue E-Mail
        On Error Resume Next
        Set objMail = objOutlook.CreateItem(0)
       
        ' Stelle die E-Mail Einstellungen richtig ein
        With objMail
            .To = strTo
            .Subject = strSubj
            .BodyFormat = 2 'olFormatHTML
            .HTMLBody = strBody
             If strAttach <> "" Then
            .Attachments.Add (strAttach)
             End If
            .Display ' Send the email
        End With


        Dim fehlerMeldung As String
        Dim sentCount As Integer
        ' Überprüfen, ob der Sendevorgang erfolgreich war oder ob es einen Fehler gab
        If Err.Number <> 0 Then
        ' Fehlerbehandlungsroutine
        fehlerMeldung = fehlerMeldung & vbCrLf & "Fehler beim Senden an " & strVorname & " " & strNachname & ": " & Err.Description
        Else
        sentCount = sentCount + 1 ' erhöhe die Anzahl der gesendeten E-Mails
        End If

        Set objMail = Nothing
        Err.Clear
        On Error GoTo 0
        Next i
        
        ' Entferne alle HTML-Tags aus dem Dokument
        objUndo.EndCustomRecord
        ActiveDocument.Undo

        ' Wenn Fehler aufgetreten sind, zeige eine Fehlermeldung
        If fehlerMeldung <> "" Then
        MsgBox "Folgende Datensätze konnten nicht gesendet werden:" & vbCrLf & fehlerMeldung
        Else ' Wenn keine Fehler aufgetreten sind, zeige eine Meldung, dass alle E-Mails erfolgreich gesendet wurden
        MsgBox "Alle E-Mails wurden erfolgreich gesendet (" & sentCount & " gesendet)."
        End If

        ' Aufräumen
        Set objMail = Nothing
        Set objOutlook = Nothing
        ' Close the Excel file
        xlWB.Close SaveChanges:=False
        xlApp.Quit
        Set xlWS = Nothing
        Set xlWB = Nothing
        Set xlApp = Nothing
        Set Pfad = Nothing
   
    Else
        MsgBox "Der Sendungsvorgang wurde nicht gestartet, da keine Datei ausgewählt wurde."
    End If
End With

End Sub

Gehe dafür zu diesen Teil des Codes:

' Stelle die E-Mail Einstellungen richtig ein
        With objMail
            .To = strTo
            .Subject = strSubj
            .BodyFormat = 2 'olFormatHTML
            .HTMLBody = strBody
             If strAttach <> "" Then
            .Attachments.Add (strAttach)
             End If
            .Send ' Send the email
        End With

Für die Änderung musst du „.Send“ zu „.Display“ verändern. Dir werden dann alle E-Mails in einem eigenen Fenster generiert. So kannst du dann jede E-Mail kontrollieren und manuell versenden.

Standardmäßig ist das verwendete Arbeitsblatt an der 1. Stelle. Möchte man das Arbeitsblatt jedoch individuell bestimmen, dann muss man die folgende Codezeile weit oben im Hauptcode

"Set xlWS = wlWB.Sheets(1)"

durch folgenden Block ersetzen:

'Es folgt ein Dialog, in der das Arbeitsblatt ausgewählt werden muss
        Dim sheetList As String

        For c = 1 To xlWB.Sheets.Count
        sheetList = sheetList & Worksheets(c).Name & ", "
        Next c
        
        sheetName = InputBox("Bitte wählen Sie ein Blatt aus, indem Sie nur noch den richtigen Arbeitsblattnamen in der Box übrig lassen:", "Blatt auswählen", sheetList)
        
        If sheetName <> "" Then
        Set xlWS = xlWB.Sheets(sheetName)
        End If

Standardmäßig fügt der Code anhand des „Herr“ oder der „Frau“ in der Zelle „Anrede“ das typische „Sehr geehrter Herr“ bzw. „Sehr geehrte Frau“ ein. Wenn man die Anrede verändern möchte, dann wäre eine Möglichkeit, dass die individuelle Anrede in der Zelle unter „Anrede“ steht (also z. B. Liebe Frau/Lieber Herr). Zusätzlich muss man im Code lediglich den folgenden Codeblock in der unteren Hälfte des gesamten Codes löschen, damit das Programm die individuelle Anrede nicht ersetzt:

 ' Überprüfe, ob die Anrede für jenes Geschlecht stimmt
        If strAnrede = "Frau" Then
            strAnrede = "Sehr geehrte Frau"
        ElseIf strAnrede = "Herr" Then
            strAnrede = "Sehr geehrter Herr"
        Else
            strAnrede = "" ' set an empty string if the value is neither "Frau" nor "Herr"
        End If

Alle Codes zum Download:

Alle Codes befinden sich als Basic-Dateien in meiner Github-Bereich und können dort angesehen und heruntergeladen werden.

Die Dateien können dann im VBA-Editor von Word unter Datei -> Datei importieren geladen werden. Das Fenster zum Modul öffnet dann nicht automatisch. Man muss es durch Doppelklick selbst öffnen.

Serien-E-Mails mit individuellen Anhängen über Outlook versenden

1.

2.

3.

Code-Variationen:

Alle Codes zum Download:

AUTOR

Lukas Collier

Schreiben Sie einen Kommentar Antworten abbrechen