Here is an example application for some of the functions I have posted previously. This sheet will take a list of recipients as an input and generate an Outlook email for each. This came about when a colleague of mine was using the traditional mail merge in office for the first time and ran into a roadblock trying to add a CC to each message. I am not an expert with mail merge, but when I looked around the first search results suggested using a rule in Outlook as a workaround. Here’s my workaround and what it does:
- Variables in the email body/subject can be entered in a similar way to mail merge, using this format <<variable>>. Just like a mad-lib.
- The same attachment can be added to each message, or a unique attachment can be added for each entry on the list
- Multiple recipients are added to the list by separating them with a semicolon
- CC and BCC are supported
- The default outlook signature can be used
- Messages can be sent immediately, or displayed in the editor to be sent manually
Ultimately this is also a workaround, but there are certainly some situations where this can be useful. It’s probably not right if you’re running an email marketing campaign, or as a replacement for billing automation software; I think it is suited to one-off or infrequent tasks like:
- Emailing unique coupon or gift certificate codes
- Sending a reminder to vendors while including their specific account numbers
- “Personalizing” an email that you would otherwise just CC or BCC to group of recipients.
- Speeding up a task where humans are copy/pasting details in to a pre-written message repeatedly
This also makes it easy to be a spammer, please don’t do that. Here is the file:
Also I used some hints from Ron de Bruin to get the signature working (thanks!): https://www.rondebruin.nl/win/s1/outlook/signature.htm. Here is the subroutine that does the work, the functions it requires can be found separately here.
Sub sendEmail()
'by Elliot 8/8/20 www.elliotmade.com
'check the sheet "Instructions" for more info
'tested with office 2010 and 2013
'method for using outlook default signature taken from here: https://www.rondebruin.nl/win/s1/outlook/signature.htm
Dim rSheetName As String, vSheetName As String, iSheetName As String
'-------------------------------------
rSheetName = "Recipients"
vSheetName = "Variables"
iSheetName = "Instructions"
'-------------------------------------
Dim rSht As Worksheet, vSht As Worksheet
Set rSht = Worksheets(rSheetName)
Set vSht = Worksheets(vSheetName)
Dim rLastRow As Long, vLastRow As Long
rLastRow = getLastRow(rSheetName, 1)
vLastRow = getLastRow(vSheetName, 1)
'fixed inputs
Dim subject As String, greeting As String, body As String, signature As String, att1 As String, att2 As String, att3 As String
subject = vSht.Cells(getRowNum("Subject", vSheetName), 2).Value2
greeting = vSht.Cells(getRowNum("Greeting", vSheetName), 2).Value2
body = vSht.Cells(getRowNum("Body", vSheetName), 2).Value2
signature = vSht.Cells(getRowNum("Signature", vSheetName), 2).Value2
att1 = vSht.Cells(getRowNum("Attachment 1", vSheetName), 2).Value2
att2 = vSht.Cells(getRowNum("Attachment 2", vSheetName), 2).Value2
att3 = vSht.Cells(getRowNum("Attachment 3", vSheetName), 2).Value2
Dim mode As String, sigMode As String
mode = vSht.Cells(getRowNum("Send Mode", vSheetName), 2).Value2
sigMode = vSht.Cells(getRowNum("Signature Mode", vSheetName), 2).Value2
Dim fixedVArray As Variant
Dim fixedVCount As Long
If vSht.Cells(getLastRow(vSheetName, 1), 1).Value2 = "Variables" Then GoTo skipFixedVariables 'skip fixed variables if there are none
fixedVArray = vSht.Range(vSht.Cells(getRowNum("Variables", vSheetName, 1) + 1, 1), vSht.Cells(vLastRow, 2)).Value
fixedVCount = UBound(fixedVArray, 1)
'replace the fixed variables into each part of the email
Dim i As Long
For i = 1 To fixedVCount
If InStr(1, subject, "<<") Then
subject = Replace(subject, fixedVArray(i, 1), fixedVArray(i, 2))
End If
If InStr(1, greeting, "<<") Then
greeting = Replace(greeting, fixedVArray(i, 1), fixedVArray(i, 2))
End If
If InStr(1, body, "<<") Then
body = Replace(body, fixedVArray(i, 1), fixedVArray(i, 2))
End If
If InStr(1, signature, "<<") Then
signature = Replace(signature, fixedVArray(i, 1), fixedVArray(i, 2))
End If
Next i
skipFixedVariables:
Dim curSubject As String, curGreeting As String, curBody As String, curSignature As String
'now go through the list of recipients, update each part of the email, then create and send it
Dim listArray As Variant 'columns 1 thru 4 are fixed: TO, CC, BCC, Attachment. Any number of variable columns can follow
Dim listRowCount As Long, listColCount As Long
listRowCount = getLastRow(rSheetName)
listColCount = getLastCol(rSheetName)
If listRowCount < 2 Then 'don't proceed if the list is empty
MsgBox "Nothing found in the recipient list"
Exit Sub
End If
listArray = rSht.Range(rSht.Cells(1, 1), rSht.Cells(listRowCount, listColCount)).Value
Dim j As Long
Dim k As Long
Dim outlookApp As Object
Dim outlookEmail As Object
Set outlookApp = CreateObject("Outlook.Application")
For j = 2 To UBound(listArray, 1)
'reset the temporary message parts
curSubject = subject
curGreeting = greeting
curBody = body
curSignature = signature
If UBound(listArray, 2) > 4 Then 'if there are variable columns, replace each of those into the current message
For k = 5 To UBound(listArray, 2)
If InStr(1, curSubject, "<<") Then
curSubject = Replace(curSubject, listArray(1, k), listArray(j, k))
End If
If InStr(1, curGreeting, "<<") Then
curGreeting = Replace(curGreeting, listArray(1, k), listArray(j, k))
End If
If InStr(1, curBody, "<<") Then
curBody = Replace(curBody, listArray(1, k), listArray(j, k))
End If
If InStr(1, curSignature, "<<") Then
curSignature = Replace(curSignature, listArray(1, k), listArray(j, k))
End If
Next k
End If
'compose the email
Set outlookEmail = outlookApp.CreateItem(0)
With outlookEmail
If sigMode = "Outlook Default" Then 'in order to get the predefined signature from outlook into the message it has to be displayed first
.display
.HTMLbody = curGreeting & "<br>" & curBody & "<br>" & .HTMLbody
Else
.HTMLbody = curGreeting & "<br><br>" & curBody & "<br><br>" & curSignature
End If
.To = listArray(j, 1)
.cc = listArray(j, 2)
.bcc = listArray(j, 3)
.subject = curSubject
'attachments
If att1 <> "" Then .Attachments.Add (att1)
If att2 <> "" Then .Attachments.Add (att2)
If att3 <> "" Then .Attachments.Add (att3)
If listArray(j, 4) <> "" Then .Attachments.Add (listArray(j, 4))
If mode = "Send" Then
.send
Else
.display
End If
End With
Set outlookEmail = Nothing
Next j
Set outlookApp = Nothing
Debug.Print
End Sub