VBScript to Automate Outlook emails via Mail Merge - batch-file

Question

Im looking for a VBScript that will automatically send an email to each person on a list of contacts I have in an excel tabel using a mail merge.
Any help would be much appreciated and if you need more info just ask :)
Basically I have this code
Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message." &vbCrLf & vbCrLf
.Importance = olImportanceHigh 'High importance
' Resolve each Recipient's name.
For Each ObjOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
But I need it to, instead of creating an email, it uses a mail merge, and the email is to be sent to everyone on a list stored in an excel sheet, problem is, I have no idea how to do this so any help would be great!
Thanks

Answer 1

This will send one email to each person listed in an excel file. For this example, the name is in column A, the email address is in column B and the subject is in column C. Create a template in the drafts folder and set the subject to "Template". In the template email, use {} around any field you want to replace with another. In this example, {name} is replaced with the name from column A. Insert the {image} tag where you want the image to go. I'm assuming you want the same image since it's a corporate logo, so you just define the path in the SendMessage Sub. This will add the image as an attachment, there is no easy way to get around that but it will be embedded into the body of the email.
set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open ("H:\Book1.xls")
'skip header row. set to 1 if you
'don't have a header row
set sh = wb.Sheets("Sheet1")
row = 2
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "H:\Scripts\Batch\pic.png", 80,680
row = row + 1
name = sh.Range("A" & row)
email = sh.Range("B" & row)
subject = sh.Range("C" & row)
'image = sh.Range("D" & row)
End if
Next
wb.close
set wb = nothing
set app = nothing
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{name}", DisplayName)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function