Word Mail Merge with Attachment

UPDATE #2:  Thanks to the comment by Tony, making 2 simple changes to the code eliminates the need for step (3) below.

I’ve commented out the line

Set oOutlookApp = GetObject(, "Outlook.Application")

and changed

Set olNS = oOutlookApp.GetNamespace("MAPI")

               to

' By following change eliminates the security access prompts!
'Set olNS = oOutlookApp.GetNamespace("MAPI")
Set olNS = ThisOutlookSession.GetNamespace("MAPI")

UPDATE: A critical line of code seems to have fallen off when I copied the code to the original post – I have added the line

Item.Save

to the code below.

For some reason, Microsoft has never supported mail merging of documents to email with an attachment.  Until now, I always managed to work around this limitation.  However, when we recently completed our Renaissance Case Studies document, I wanted to send out the PDF to our email distribution list.

Alas, a quick search for mail-merging with attachments returns a bunch of commercial tools, but there was only one good example of VBA code to do this in word – found here.  Unfortunately, for some reason I was not able to get that code to work and didn’t have/want to spend the time to debug it (it could very well have been some silly/simple issue on my part).  Instead I used it as a starting point for my own VBA function, which I will share below.

Before I get to the code, let me outline the steps to create the final emails:

(1) Create a normal email mail-merge document – without any attachment – and generate the emails to be sent.

(2) Execute the VBA function / Macro Set Attachment and enter the full path to the desired attachment when prompted by the dialog.

(3) You will normally be prompted with a security warning dialog for each outgoing message that you try to access.  If you are sending more than just a few emails at a time here, I suggest you that you download and run the free utility Express ClickYes to automatically click yes for you every time.

Here is the VBA code I used for the SetAttachment function/Macro.  It is provided “As is” – it worked well for me, but you’ll have to confirm and/or modify it for your scenarios.

Sub SetAttachment()
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Item As Outlook.MailItem
Dim Filepath As String, message As String, title As String

' This sub assumes that this macro is being run from within Outlook
On Error Resume Next
‘Set OutlookApp = GetObject(, "Outlook.Application")

message = "Enter the full path to the attachment."    ' Set prompt.
title = " Email Attachment Path"    ' Set title.

' Display message, title
Filepath = InputBox(message, title)

' iterate through all items in the Outlook Outbox
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim count As Integer

' By following change eliminates the security access prompts!
'Set olNS = oOutlookApp.GetNamespace("MAPI")
Set olNS = ThisOutlookSession.GetNamespace("MAPI")

Set MyFolder = olNS.GetDefaultFolder(olFolderOutbox)
    For i = 1 To MyFolder.Items.count
        Set Item = MyFolder.Items(i)
        Item.Attachments.Add Trim(Filepath), olByValue, 1
        Item.Save 
        Item.Send
        count = count + 1
    Next i
    Set Item = Nothing

MsgBox count & " files have been attached."

'Clean up
Set OutlookApp = Nothing

End Sub