Combine Mail Merge to Distribution List with Auto Attachments - Outlook 2007


Outlook version
Outlook 2007
Email Account

I'm trying to combine the following two pieces of code, both of which were found online, into a macro that will:

1. Loop through a distribution list

2. Create a new email for each listed email address

3. Attach a PDF to each email based on the name in the "to field"

4. Save the completed email in the Drafts Folder for review

I've been fiddling around for a couple of days and can't get it to work at all. I employ the copy, paste, and pray programming model, which may be part of my problem. I thought I'd post it here for you fine folks to look at.

Things to note:

The documents are named like so: Doe, John - Weekly Statement.

The "to field" is formatted as such:

Alternatively, the files are (pretty much) saved in the same order as the names appear in the distribution list. I imagine that this could be used in a loop (i.e. tell Outlook to grab the first file in the folder and attach to the email made from the first name in the list).

Here's the mail merge code:


Sub Merge_Earned_to_Group() 
Dim o_list As Object 
Dim objMsg As MailItem 
Set o_list = GetCurrentItem() 
For i = 1 To o_list.MemberCount 
Set objMsg = Application.CreateItem(olMailItem) 
With objMsg
 .To = o_list.GetMember(i).Address
 'Cycle Date Must Be Changed Every Cycle
 .Subject = "Earned Income for the period October 16-31 2013"
 .Body = "The following are details of your current income payable for the above period." & vbNewLine & _
 "Your current income can be found on the bottom far right corner of your attached document." & vbNewLine
 .Close olPromptForSave 
End With 
Set objMsg = Nothing
End Sub
 Function GetCurrentItem() As Object 
Dim objApp As Outlook.Application 
Set objApp = Application 
On Error Resume Next 
Select Case TypeName(objApp.ActiveWindow) 
Case "Explorer" 
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) 
Case "Inspector" 
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem 
End Select 
Set objApp = Nothing 
End Function
Here's the automatic attachment code:


Sub SendFilesinFolder() 
Dim sFName As String   
sFName = Dir("C:\Users\walu22\Individual Statements\")Do While Len(sFName) > 0 
Call SendasAttachment(sFName) 
sFName = Dir 
End Sub 
Function SendasAttachment(fName As String) 
Dim olApp As Outlook.Application 
Dim olMsg As Outlook.MailItem 
Dim olAtt As Outlook.Attachments 
Dim strName As String 
strName = InputBox("Enter first 4 characters of filename")
Do While Len(fName) > 0
 If Left(fName, 4) = strName Then
   olAtt.Add fldName & fName
   sAttName = fName & "<br />" & sAttName
  End If
  fName = Dir 
Set olApp = Outlook.Application 
Set olMsg = olApp.CreateItem(0) ' email 
Set olAtt = olMsg.Attachments 
' attach file 
olAtt.Add ("C:\Users\walu22\Individual Statements" & fName) 
With olMsg 
> Subject = "Here's that file you wanted" 
> To = "[EMAIL=""][/EMAIL]" 
> HTMLBody = "Hi " & olMsg.To & "," & vbCrLf & "Attached is " & fName & " you requested." 
> Send 
End With 
End Function

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Re: Combine Mail Merge to Distribution List with Auto Attachments - Outlook 20

This is the problem:

The documents are named like so: Doe, John - Weekly Statement.
The "to field" is formatted as such:
if Doe, john is resolvable to your contacts, you can strip the rest of the file name off and let outlook resolve it. My only concern would be if you had two john doe's. In that case, a file named "Doe, John - clientcompany - Weekly Statement" would be better, because you could check the address for the domain. You could also popup a dialog displaying the resolved address, but that gets old quick

Similar threads