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