Mail merge with attachments

In Outlook® you can sent mass mails but without attachments.

With the following code you can send mass mails with attachments by category. If you do not work with categories please set the constant MYCATEGORIES As String = "".

First of all create an e-mail without recipients but with subject and attachments and save it as a template (.oft). The code uses a template called Mail.oft and is saved to C:\.

If the e-mails will not be sent imeadetly they will be saved per default in the drafts folder. To sent these e-mails mark them and drag them into the outbox folder. In the article E-mail remains in the outbox you find out how these e-mails can be sent.

The code works for plain text and HTML e-mails. HTML e-mails may not have the same font as the inserted salutation. For this reason the constant CSSTITLE will be used. With this constant you can format the salutation as you want. Therfore you need some CSS knowledge but the important properties are already available.

The original code askes you every time for a folder with reciepients. If you use always the same folder or if you have only one folder you can predefine the folder. Pleas read the comment Predefine contact folder.

To use this example please read the important notes and have a look to the workshop Use VBA in Outlook®. You can insert this code into a new module (Insert -> Module in the VBA-Editor).

For Outlook® 2002, Outlook® 2003, Outlook® 2007

Option Explicit
 
' Sent e-mails only to this categories:
' Seperate multiple categories by a colon (;)
' Leave empty to send to all contacts
Private Const MYCATEGORIES As String = ""
 
' Mail template (with or without attachments):
Private Const TEMPLATE As String = "C:\Mail.oft"
 
' CSS code to format the title in HTML-e-mails:
Private Const CSSTITLE As String = _
    "font-family: Arial; font-size: 10pt; color: black; font-weight: normal"
 
' Titel for dialogs:
Private Const MSGBOXTITLE As String = "Create Mail Merge"
 
Public Sub MailMerge()
 
    '=====================================================================
    ' Creates e-mails from a contact folder (by category) with attachments
    ' (and send it).
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-11-05 Version 1.0.0
    '=====================================================================
 
    Dim vbResult As VBA.VbMsgBoxResult      ' User action
 
    Dim objFolder As Outlook.MAPIFolder     ' Contact folder
    Dim objItems As Outlook.Items           ' Items of a folder
    Dim objContact As Outlook.ContactItem   ' Single contact
    Dim objMail As Outlook.MailItem         ' Single E-Mail
 
    Dim strFilter As String                 ' Filter
 
    Dim lngMails As Long                    ' Created e-mails
    Dim blnSend As Boolean                  ' Send e-mail imeadetly?
 
    '---------------------------------------------------------------------
    ' Predefine a contact folder (for the Business contacts of the
    ' Business Contact Manager please remove the first and second apostrophe,
    ' for the default contacts folder please remove only the last apostrophe).
    '---------------------------------------------------------------------
    'Set objFolder = Outlook.Session.Folders("Business Contact Manager")
    'Set objFolder = objFolder.Folders("Business Contacts")
    'Set objFolder = Outlook.Session.GetDefaultFolder(olFolderContacts)
 
    '---------------------------------------------------------------------
    ' If no folder is predefined a folder picker will be shown
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Set objFolder = ChooseFolder
 
    '---------------------------------------------------------------------
    ' No contacts folder predefined/choosen?
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Send e-mails imeadetly?
    '---------------------------------------------------------------------
    vbResult = MsgBox("Should the e-mails be send imeadetly?", vbQuestion + _
        vbYesNoCancel + vbDefaultButton2, MSGBOXTITLE)
    If vbResult = vbYes Then
        blnSend = True
    ElseIf vbResult = vbCancel Then
        GoTo ExitProc
    End If
 
    '---------------------------------------------------------------------
    ' Some time for the message box to close
    '---------------------------------------------------------------------
    DoEvents
 
    '---------------------------------------------------------------------
    ' Reference the elements in the folder
    '---------------------------------------------------------------------
    Set objItems = objFolder.Items
 
    '---------------------------------------------------------------------
    ' Only contacts are needed, no distlists. To filter by categories is
    ' not possible with VBA, otherwise it could be done here too.
    '---------------------------------------------------------------------
    strFilter = "[MessageClass] <> ""IPM.DistList"""
 
    '---------------------------------------------------------------------
    ' Filter the elements
    '---------------------------------------------------------------------
    Set objItems = objItems.Restrict(strFilter)
 
    '---------------------------------------------------------------------
    ' Proceed the contacts
    '---------------------------------------------------------------------
    For Each objContact In objItems
 
        '-----------------------------------------------------------------
        ' If he containst the specified category the e-mail will be created
        '-----------------------------------------------------------------
        If CreateMail(objContact.Categories) Then
 
            '-------------------------------------------------------------
            ' Create new e-mail from template
            '-------------------------------------------------------------
            Set objMail = Outlook.CreateItemFromTemplate(TEMPLATE)
 
            With objMail
 
                '---------------------------------------------------------
                ' E-mail address is missing?
                '---------------------------------------------------------
                If InStr(objContact.Email1Address, "@") = 0 Then
                    If MsgBox("The contact """ & objContact.FullName & _
                        """ has no e-mail address.", vbExclamation + _
                        vbOKCancel, MSGBOXTITLE) = vbCancel Then Exit Sub
                    GoTo Skippy
                End If
 
                '---------------------------------------------------------
                ' Set the e-mail address
                '---------------------------------------------------------
                If Left(Trim(objContact.Email1DisplayName), 1) = "(" Then
                    .To = objContact.Email1Address
                Else
                    .To = objContact.Email1DisplayName
                End If
 
                '---------------------------------------------------------
                ' Get the salutation and insert it
                '---------------------------------------------------------
                Call InsertHello(objMail, objContact)
 
                '---------------------------------------------------------
                ' Save new e-mail (Default is the folder "Drafts")
                '---------------------------------------------------------
                .Save
 
                '---------------------------------------------------------
                ' If send then send
                '---------------------------------------------------------
                If blnSend Then .Send
 
                '---------------------------------------------------------
                ' Increase counter for summary message
                '---------------------------------------------------------
                lngMails = lngMails + 1
 
            End With
 
        End If
 
Skippy:
 
        '-----------------------------------------------------------------
        ' Clear reference to the contact
        '-----------------------------------------------------------------
        Set objContact = Nothing
 
        '-----------------------------------------------------------------
        ' Clear reference to the e-mail
        '-----------------------------------------------------------------
        Set objMail = Nothing
 
    Next
 
    '---------------------------------------------------------------------
    ' Inform user
    '---------------------------------------------------------------------
    If blnSend Then
        MsgBox "Sent e-mails: " & lngMails & Chr(9), vbInformation _
            + vbOKOnly, MSGBOXTITLE
    Else
        MsgBox "Created e-mails: " & lngMails & Chr(9), vbInformation + _
            vbOKOnly, MSGBOXTITLE
    End If
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clear references
    '---------------------------------------------------------------------
    Set objItems = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Function ChooseFolder() As Outlook.MAPIFolder
 
    '=====================================================================
    ' Returns a choosen contact folder
    ' 2008-11-05 Version 1.0.0
    '=====================================================================
 
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Show a hint
    '---------------------------------------------------------------------
    If MsgBox("Please choose in the next dialog the" & vbCrLf & _
        "contact folder with the desired reciepients.", vbInformation _
        + vbOKCancel, MSGBOXTITLE) = vbCancel Then Exit Function
 
    '---------------------------------------------------------------------
    ' Stay in loop until a valid contact folder was choosen or the user
    ' breaked the dialog
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Show the folder picker
        '-----------------------------------------------------------------
        Set objFolder = Nothing
        Set objFolder = Outlook.Session.PickFolder
 
        '-----------------------------------------------------------------
        ' User cancled?
        '-----------------------------------------------------------------
        If objFolder Is Nothing Then Exit Function
 
        '-----------------------------------------------------------------
        ' Wrong folder type?
        '-----------------------------------------------------------------
        If InStr(objFolder.DefaultMessageClass, "IPM.Contact") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Please choose a folder for contacts." _
                , vbCritical + vbOKCancel, "Choose contact folder") = vbCancel Then
                Exit Function
            End If
        End If
 
    Loop While objFolder Is Nothing
 
    '---------------------------------------------------------------------
    ' Return folder and/or nothing
    '---------------------------------------------------------------------
    Set ChooseFolder = objFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function
 
Private Function CreateMail(ByVal strCategories As String) As Boolean
 
    '=====================================================================
    ' Returns true if the contact contains the defined categories
    ' 2008-11-05 Version 1.0.0
    '=====================================================================
 
    Dim aryContactCats() As String    ' Array with categories of the contact
    Dim aryConstantCats() As String   ' Array with categories of the constant
 
    Dim lngConstant As Long     ' Loop counter for the constant
    Dim lngContact As Long      ' Loop counter for the contact
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' If no categories are defined the e-mail will be sent always
    '---------------------------------------------------------------------
    If Trim(Replace(MYCATEGORIES, ";", "")) = "" Then
        CreateMail = True
        Exit Function
    End If
 
    '---------------------------------------------------------------------
    ' Load the contacts categories into a field
    '---------------------------------------------------------------------
    aryContactCats() = Split(strCategories, ";")
 
    '---------------------------------------------------------------------
    ' Load the constants categories into a field
    '---------------------------------------------------------------------
    aryConstantCats() = Split(MYCATEGORIES, ";")
 
    '---------------------------------------------------------------------
    ' Contains the contact all categories of the constant?
    '---------------------------------------------------------------------
    For lngConstant = 0 To UBound(aryConstantCats())
 
        '-----------------------------------------------------------------
        ' Reset function
        '-----------------------------------------------------------------
        CreateMail = False
 
        '-----------------------------------------------------------------
        ' Proceed all categories of the contact
        '-----------------------------------------------------------------
        For lngContact = 0 To UBound(aryContactCats())
 
            '-------------------------------------------------------------
            ' If he contains the searched category this function will be
            ' set to "True"
            '-------------------------------------------------------------
            If LCase(Trim(aryContactCats(lngContact))) = _
                LCase(aryConstantCats(lngConstant)) Then
                CreateMail = True
                Exit For
            End If
 
        Next
 
        '-----------------------------------------------------------------
        ' End, if the contact did not contain the category
        '-----------------------------------------------------------------
        If Not CreateMail Then Exit For
 
    Next
 
End Function
 
Private Sub InsertHello(ByRef objMail As Outlook.MailItem, _
    ByVal objContact As Outlook.ContactItem)
 
    '=====================================================================
    ' Gets the salutation and insert it into the e-mail
    ' 2008-11-05 Version 1.0.0
    '=====================================================================
 
    Dim lngBodyEnd As Long     ' End of the body tag
 
    With objMail
 
        '-----------------------------------------------------------------
        ' Get the end of the body line (for HTML e-mails)
        '-----------------------------------------------------------------
        lngBodyEnd = InStr(LCase(.HTMLBody), "<body")
        If lngBodyEnd Then lngBodyEnd = InStr(lngBodyEnd + 1, .HTMLBody, ">")
 
        '-----------------------------------------------------------------
        ' If a last name exists this will be used
        '-----------------------------------------------------------------
        If Trim(objContact.LastName) <> "" Then
 
            '-------------------------------------------------------------
            ' Exists a German male title?
            '-------------------------------------------------------------
            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
 
            '-------------------------------------------------------------
            ' Exists a German female title?
            '-------------------------------------------------------------
            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
 
            '-------------------------------------------------------------
            ' Exists an English male title?
            '-------------------------------------------------------------
            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
 
            '-------------------------------------------------------------
            ' Exists an English female title?
            '-------------------------------------------------------------
            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
 
        '-----------------------------------------------------------------
        ' No title exists -> use a general salutation
        '-----------------------------------------------------------------
        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