Serienmails mit Anhängen

In Outlook® gibt es das Problem, dass zwar Serienmails gesendet werden können, jedoch nicht mit Anhängen.

Mit dem untenstehenden Code können Sie Serienmails in Outlook® auch mit Anhängen versenden und das auch noch abhängig von bestimmten Kategorien. Möchten Sie unabhängig von einer Kategorie sein, setzen Sie die Konstante MYCATEGORIES As String = "".

Eine komfortable Serienmailfunktion mit Anlagen und persönlicher Anrede finden Sie auch in dem Tool ContactMaker Pro wieder.

Der ContactMaker Pro hat neben vielen weiteren nützlichen Funktionen für Ihr Kontaktmanagement auch eine leistungsstarke Serien-E-Mail-Funktion an Board.

Machen Sie sich das Leben einfacher und testen Sie den ContactMaker Pro jetzt kostenlos für 30 Tage!

Alle Bastler erstellen Sie zunächst die gewünschte E-Mail ohne Empfänger, aber mit Betreff und den entsprechenden Anlagen und speichern Sie diese als Vorlage (.oft) ab. Im Code wird eine Vorlage namens Mail.oft verwendet, welche auf C:\ gespeichert ist. Sie können natürlich auch ein beliebiges anderes Verzeichnis verwenden.

Werden die E-Mails nicht sofort gesendet, werden Sie standardmäßig im Ordner Entwürfe abgelegt. Um die E-Mails zu versenden, markieren Sie diese und ziehen Sie sie in den Postausgang. In dem Beitrag E-Mail bleibt im Postausgang liegen erfahren Sie, wie die E-Mails dann automatisch verschickt werden.

Der Code funktioniert für Nur-Text- und HTML-E-Mails. Bei HTML-E-Mails gibt es die Besonderheit, dass die Schrift der automatisch eingefügten Begrüßung nicht zwingend das richtige Format hat. Um das zu umgehen, wurde die Konstante CSSTITLE verwendet, mit deren Hilfe Sie die Schriftart der Begrüßung an die Schriftart der E-Mail anpassen können. Dazu sind etwas CSS-Kenntnisse erforderlich. Die wichtigsten Eigenschaften (Schriftart, Größe, Farbe und Stärke) sind bereits enthalten und können relativ einfach angepasst werden.

Im Originalzustand des Codes werden Sie jedesmal nach einem Ordner mit den Empfängern gefragt. Falls Sie immer den gleichen Ordner verwenden, bzw. nur 1 Kontakteordner haben, finden Sie im Kommentar bei Kontakteordner vorbelegen Hinweise, wie Sie diesen fest einstellen können.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Ab Outlook® 2002

Option Explicit
 
' E-Mails nur an diese Kategoie(n) senden:
' Mehrere Kategorien durch Semikolon (;) trennen
' Leerlassen, wenn an alle senden
Private Const MYCATEGORIES As String = ""
 
' E-Mailvorlage (mit oder ohne Anhang):
Private Const TEMPLATE As String = "C:\Mail.oft"
 
' CSS-Angabe, um Titel in HTML-E-Mails zu formatieren:
Private Const CSSTITLE As String = _
    "font-family: Arial; font-size: 10pt; color: black; font-weight: normal"
 
' Titel für Dialogfelder:
Private Const MSGBOXTITLE As String = "Serienmail erstellen"
 
Public Sub MailMerge()
 
    '=====================================================================
    ' Erstellt kategorieabhängig E-Mails von einem bestimmten Kontakte-
    ' ordner aus einer Vorlage und verschickt diese auf Wunsch sofort.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-05 Version 1.0.0
    '=====================================================================
    
    Dim vbResult As VBA.VbMsgBoxResult          ' Benutzerreaktion
    
    Dim objFolder As Outlook.MAPIFolder         ' Kontakteordner
    Dim objItems As Outlook.Items               ' Elemente eines Ordners
    Dim objContact As Outlook.ContactItem       ' Einzelner Kontakt
    Dim objMail As Outlook.MailItem             ' Einzelne E-Mail
    
    Dim strFilter As String                     ' Filterkriterium
    
    Dim lngMails As Long                        ' Erstellte E-Mails
    Dim blnSend As Boolean                      ' E-Mails sofort senden
    
    '---------------------------------------------------------------------
    ' Kontakteordner vorbelegen (für die Geschäftskontakte aus dem
    ' Business Contact Manager bitte die ersten beiden Hochkomma entfernen,
    ' für den Standardkontakteordner bitte nur das 3. Hochkomma entfernen).
    '---------------------------------------------------------------------
    'Set objFolder = Outlook.Session.Folders("Business Contact Manager")
    'Set objFolder = objFolder.Folders("Geschäftskontakte")
    'Set objFolder = Outlook.Session.GetDefaultFolder(olFolderContacts)
        
    '---------------------------------------------------------------------
    ' Ist kein Ordner vorbelegt, wird eine Ordnerauswahl angezeigt
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Set objFolder = ChooseFolder
 
    '---------------------------------------------------------------------
    ' Keinen Kontakteordner vorbelegt/ausgewählt?
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Mails gleich verschicken?
    '---------------------------------------------------------------------
    vbResult = MsgBox("Sollen die E-Mails sofort gesendet werden?", vbQuestion + _
        vbYesNoCancel + vbDefaultButton2, MSGBOXTITLE)
    If vbResult = vbYes Then
        blnSend = True
    ElseIf vbResult = vbCancel Then
        GoTo ExitProc
    End If
 
    '---------------------------------------------------------------------
    ' Dem Hinweis Zeit geben, damit er geschlossen werden kann
    '---------------------------------------------------------------------
    DoEvents
 
    '---------------------------------------------------------------------
    ' Elemente im Ordner referenzieren
    '---------------------------------------------------------------------
    Set objItems = objFolder.Items
 
    '---------------------------------------------------------------------
    ' Nur Kontakte sind gewünscht, keine Verteilerlisten. Nach Kategorien
    ' kann mit VBA leider nicht gefiltert werden, sonst hätte man das hier
    ' mit erledigen können.
    '---------------------------------------------------------------------
    strFilter = "[MessageClass] <> ""IPM.DistList"""
 
    '---------------------------------------------------------------------
    ' Elemente filtern
    '---------------------------------------------------------------------
    Set objItems = objItems.Restrict(strFilter)
 
    '---------------------------------------------------------------------
    ' Kontakte abarbeiten
    '---------------------------------------------------------------------
    For Each objContact In objItems
 
        '-----------------------------------------------------------------
        ' Enthält er die gesuchte Kategorie wird eine E-Mail erstellt
        '-----------------------------------------------------------------
        If CreateMail(objContact.Categories) Then
 
            '-------------------------------------------------------------
            ' Neue E-Mail aus Vorlage erstellen
            '-------------------------------------------------------------
            Set objMail = Outlook.CreateItemFromTemplate(TEMPLATE)
 
            With objMail
 
                '---------------------------------------------------------
                ' Hinweis, wenn E-Mailadresse fehlt'
                '---------------------------------------------------------
                If InStr(objContact.Email1Address, "@") = 0 Then
                    If MsgBox("Der Kontakt """ & objContact.FullName & _
                        """ hat keine E-Mailadresse.", vbExclamation + _
                        vbOKCancel, MSGBOXTITLE) = vbCancel Then Exit Sub
                    GoTo Skippy
                End If
 
                '---------------------------------------------------------
                ' E-Mailadresse setzen
                '---------------------------------------------------------
                If Left(Trim(objContact.Email1DisplayName), 1) = "(" Then
                    .To = objContact.Email1Address
                Else
                    .To = objContact.Email1DisplayName
                End If
 
                '---------------------------------------------------------
                ' Begrüßung ermitteln und einfügen
                '---------------------------------------------------------
                Call InsertHello(objMail, objContact)
 
                '---------------------------------------------------------
                ' Neue E-Mail speichern (Standard ist der Ordner "Entwürfe")
                '---------------------------------------------------------
                .Save
 
                '---------------------------------------------------------
                ' Wenn versenden, dann versenden
                '---------------------------------------------------------
                If blnSend Then .Send
 
                '---------------------------------------------------------
                ' Zähler für Meldung erhöhen
                '---------------------------------------------------------
                lngMails = lngMails + 1
 
            End With
 
        End If
 
Skippy:
 
        '-----------------------------------------------------------------
        ' Referenz auf Kontakt löschen
        '-----------------------------------------------------------------
        Set objContact = Nothing
 
        '-----------------------------------------------------------------
        ' Referenz auf E-Mail löschen
        '-----------------------------------------------------------------
        Set objMail = Nothing
 
    Next
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer
    '---------------------------------------------------------------------
    If blnSend Then
        MsgBox "E-Mails versendet: " & lngMails & Chr(9), vbInformation _
            + vbOKOnly, MSGBOXTITLE
    Else
        MsgBox "E-Mails erstellt: " & lngMails & Chr(9), vbInformation + _
            vbOKOnly, MSGBOXTITLE
    End If
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Referenzen löschen
    '---------------------------------------------------------------------
    Set objItems = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Function ChooseFolder() As Outlook.MAPIFolder
 
    '=====================================================================
    ' Gibt einen ausgewählten Kontakteordner zurück
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
    
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Hinweis anzeigen
    '---------------------------------------------------------------------
    If MsgBox("Bitte wählen Sie im nächsten Dialog den" & vbCrLf & _
        "Kontakteordner mit den gewünschten Empfängern aus.", vbInformation _
        + vbOKCancel, MSGBOXTITLE) = vbCancel Then Exit Function
 
    '---------------------------------------------------------------------
    ' Schleife wird solange durchlaufen, bis ein gültiger Ordner ausgewählt
    ' oder die Auswahl abgebrochen wird.
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Ordnerauswahl anzeigen
        '-----------------------------------------------------------------
        Set objFolder = Nothing
        Set objFolder = Outlook.Session.PickFolder
 
        '-----------------------------------------------------------------
        ' Wurde die Auswahl abgebrochen?
        '-----------------------------------------------------------------
        If objFolder Is Nothing Then Exit Function
 
        '-----------------------------------------------------------------
        ' Falscher Ordnertyp ausgew&auml;hlt?
        '-----------------------------------------------------------------
        If InStr(objFolder.DefaultMessageClass, "IPM.Contact") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Bitte wählen Sie einen Ordner für Kontakte aus." _
                , vbCritical + vbOKCancel, "Kontakteordner auswählen") = vbCancel Then
                Exit Function
            End If
        End If
 
    Loop While objFolder Is Nothing
 
    '---------------------------------------------------------------------
    ' Ordner bzw. Nothing zurückgeben
    '---------------------------------------------------------------------
    Set ChooseFolder = objFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function
 
Private Function CreateMail(ByVal strCategories As String) As Boolean
 
    '=====================================================================
    ' Gibt wahr zurück, wenn der Kontakt die gewünschte(n) Kategorie(n)
    ' enthält
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
    
    Dim aryContactCats() As String   ' Feld mit Kategorien des Kontakts
    Dim aryConstantCats() As String  ' Feld mit Kategorien der Konstante
    
    Dim lngConstant As Long          ' Schleifenzähler des Konstanten
    Dim lngContact As Long           ' Schleifenzähler der Kontakts
    
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Sind keine Kategorien festgelegt, wird die E-Mail immer gesendet
    '---------------------------------------------------------------------
    If Trim(Replace(MYCATEGORIES, ";", "")) = "" Then
        CreateMail = True
        Exit Function
    End If
 
    '---------------------------------------------------------------------
    ' Kategorien des Kontakts in ein Feld laden
    '---------------------------------------------------------------------
    aryContactCats() = Split(strCategories, ";")
 
    '---------------------------------------------------------------------
    ' Kategorien der Konstante in ein Feld laden
    '---------------------------------------------------------------------
    aryConstantCats() = Split(MYCATEGORIES, ";")
 
    '---------------------------------------------------------------------
    ' Enthält der Kontakt alle Kategorien der Konstanten?
    '---------------------------------------------------------------------
    For lngConstant = 0 To UBound(aryConstantCats())
 
        '-----------------------------------------------------------------
        ' Funktion zurücksetzen
        '-----------------------------------------------------------------
        CreateMail = False
 
        '-----------------------------------------------------------------
        ' Alle Kategorien des Kontakts abarbeiten
        '-----------------------------------------------------------------
        For lngContact = 0 To UBound(aryContactCats())
 
            '-------------------------------------------------------------
            ' Wenn eine mit der gesuchten Kategorie übereinstimmt, wird
            ' die Funktion auf "Wahr" gesetzt.
            '-------------------------------------------------------------
            If LCase(Trim(aryContactCats(lngContact))) = _
                LCase(aryConstantCats(lngConstant)) Then
                CreateMail = True
                Exit For
            End If
 
        Next
 
        '-----------------------------------------------------------------
        ' Wurde die Kategorie nicht im Kontakt gefunden, wird beendet
        '-----------------------------------------------------------------
        If Not CreateMail Then Exit For
 
    Next
 
End Function
 
Private Sub InsertHello(ByRef objMail As Outlook.MailItem, _
    ByVal objContact As Outlook.ContactItem)
 
    '=====================================================================
    ' Ermittelt die Begrüßung und setzt sie in die E-Mail ein
    ' 2008-11-21 Version 1.0.0
    '=====================================================================
    
    Dim lngBodyEnd As Long     ' Ende des Body-Tags
    
        With objMail
 
        '-----------------------------------------------------------------
        ' Bei HTML-Mails ende der Bodyzeile ermitteln
        '-----------------------------------------------------------------
        lngBodyEnd = InStr(LCase(.HTMLBody), "<body")
        If lngBodyEnd Then lngBodyEnd = InStr(lngBodyEnd + 1, .HTMLBody, ">")
 
        '-----------------------------------------------------------------
        ' Hat der Kontakt einen Nachnamen, so wird dieser verwendet
        '-----------------------------------------------------------------
        If Trim(objContact.LastName) <> "" Then
 
            '-------------------------------------------------------------
            ' Existiert eine deutsche, männliche Anrede?
            '-------------------------------------------------------------
            If objContact.Title = "Herr" Then
 
                If .BodyFormat = olFormatHTML Then
                    .HTMLBody = Left(.HTMLBody, lngBodyEnd) & _
                        "<span style=" & Chr(34) & CSSTITLE & Chr(34) & _
                        ">Sehr geehrter Herr " & objContact.LastName & _
                        ",</span><br><br>" & Mid(.HTMLBody, lngBodyEnd + 1)
                Else
                    .Body = "Sehr geehrter Herr " & objContact.LastName _
                        & "," & vbCrLf & vbCrLf & .Body
                End If
 
            '-------------------------------------------------------------
            ' Existiert eine deutsche, weibliche Anrede?
            '-------------------------------------------------------------
            ElseIf objContact.Title = "Frau" Then
 
                If .BodyFormat = olFormatHTML Then
                    .HTMLBody = Left(.HTMLBody, lngBodyEnd) & _
                        "<span style=" & Chr(34) & CSSTITLE & Chr(34) & _
                        ">Sehr geehrte Frau " & objContact.LastName & _
                        ",</span><br><br>" & Mid(.HTMLBody, lngBodyEnd + 1)
                Else
                    .Body = "Sehr geehrte Frau " & objContact.LastName _
                        & "," & vbCrLf & vbCrLf & .Body
                End If
 
            '-------------------------------------------------------------
            ' Existiert eine englische, männliche Anrede?
            '-------------------------------------------------------------
            ElseIf LCase(objContact.Title) = "mr." Then
 
                If .BodyFormat = olFormatHTML Then
                    .HTMLBody = Left(.HTMLBody, lngBodyEnd) & _
                        "<span style=" & Chr(34) & CSSTITLE & Chr(34) & _
                        ">Dear Mr. " & objContact.LastName & _
                        ",</span><br><br>" & Mid(.HTMLBody, lngBodyEnd + 1)
                Else
                    .Body = "Dear Mr. " & objContact.LastName _
                    & "," & vbCrLf & vbCrLf & .Body
                End If
 
            '-------------------------------------------------------------
            ' Existiert eine englische, weibliche Anrede?
            '-------------------------------------------------------------
            ElseIf LCase(objContact.Title) = "mrs." Then
 
                If .BodyFormat = olFormatHTML Then
                    .HTMLBody = Left(.HTMLBody, lngBodyEnd) & _
                        "<span style=" & Chr(34) & CSSTITLE & Chr(34) & _
                        ">Dear Mrs. " & objContact.LastName & _
                        ",</span><br><br>" & Mid(.HTMLBody, lngBodyEnd + 1)
                Else
                    .Body = "Dear Mrs. " & objContact.LastName _
                    & "," & vbCrLf & vbCrLf & .Body
                End If
 
            End If
 
        '-----------------------------------------------------------------
        ' Keine Anrede vorhanden -> Allgemeine Anrede verwenden
        '-----------------------------------------------------------------
        Else
 
            If .BodyFormat = olFormatHTML Then
                .HTMLBody = Left(.HTMLBody, lngBodyEnd) & _
                    "<span style=" & Chr(34) & CSSTITLE & Chr(34) & _
                    ">Dear ladies and sirs," & _
                    "</span><br><br>" & Mid(.HTMLBody, lngBodyEnd + 1)
            Else
                .Body = "Dear ladies and sirs," & vbCrLf & _
                    vbCrLf & .Body
            End If
 
        End If
 
    End With
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objContact = Nothing
 
End Sub