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

[walu22]

Hello,

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: john.doe@clientcompany.com

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:

Source:http://www.slipstick.com/developer/mail-merge-members-contact-group/

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
 .Display
 .Save
 .Close olPromptForSave 
 
End With 
 
Set objMsg = Nothing
  
 
Next 
 
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:

Source:http://www.slipstick.com/developer/macro-send-files-email/

Sub SendFilesinFolder() 
 
Dim sFName As String   
 
sFName = Dir("C:\Users\walu22\Individual Statements\")Do While Len(sFName) > 0 
 
Call SendasAttachment(sFName) 
 
sFName = Dir 
 
Loop 
 
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 
 
Loop 
 
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="alias@domain.com"]alias@domain.com[/EMAIL]" 
 
> HTMLBody = "Hi " & olMsg.To & "," & vbCrLf & "Attached is " & fName & " you requested." 
 
> Send 
 
End With 
 
End Function

 

[Diane Poremsky]

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: john.doe@clientcompany.com

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