Sub EnhancedMailMergeToEmail()
' Macro created by Imnoss Ltd
' Please share freely while retaining attribution
' Last Updated 2022-09-22
' Please make sure you copy all the text in this code snippit box, including the function "StripToLcaseLetters" below this sub.
' declare variables
Dim outlookApp As Object 'Outlook.Application
Dim outlookMail As Object 'Outlook.MailItem
Dim outlookAccount As Object 'Outlook.Account
Dim mm As MailMerge
Dim df As MailMergeDataField
Dim singleDoc As Document
Dim lastRecordNum As Long
Dim sendFlag As Boolean
Dim inputDate As Date
Dim toString As String
Dim ccString As String
Dim bccString As String
Dim subjectString As String
Dim errorString As String
Dim contOnError As Boolean
Dim fso As Object
' identify the mail merge of the active document
Set mm = ActiveDocument.MailMerge
' check for the mail merge state being that of a mail merge ready To go
If mm.State <> wdMainAndDataSource Then
If MsgBox("Mailmerge not set up for active document - cannot perform mailmerge. Macro will exit." & _
vbLf & vbLf & "Please click the Edit Recipient List button To confirm that mail merge is correctly setup for this document." _
, vbOKOnly + vbCritical, "Error") = vbOK Then Exit Sub
End If
' Give the user an opportunity To abort, and also the option To save the emails in drafts, or send immediately
Select Case MsgBox("MailMerge To email has found " & mm.DataSource.RecordCount & " records." & vbLf & vbLf & _
"Macro will ignore records that have been unchecked in the 'Edit Recipients' dialog box." & vbLf & vbLf & _
"Click 'Yes' To send the emails immediately, 'No' To save the emails in draft, and 'Cancel' To abort.", _
vbYesNoCancel + vbDefaultButton2 + vbQuestion, "Send Emails")
Case vbCancel
Exit Sub
Case vbYes
sendFlag = True
Case Else
sendFlag = False
End Select
ActiveDocument.Content.Characters(1).Select
' set outlookApp which is used To control outlook To send an email
' use late binding so that if the reference is not added there is not an error
Set outlookApp = CreateObject("Outlook.Application")
' go To the last record and record the record number
' if records are unchecked then the last record may not equal the record count
mm.DataSource.ActiveRecord = wdLastRecord
lastRecordNum = mm.DataSource.ActiveRecord
mm.DataSource.ActiveRecord = wdFirstRecord
' loop through all the records
Do While lastRecordNum > 0
' set fields To be populated for each email
errorString = ""
toString = "
it-apac-exit@amazon.com"
ccString = "
mnl-apac-exits@amazon.ph"
bccString = "
mnl-apac-exits@amazon.ph"
SentOnBehalfOfName = "
mnl-exits@amazon.com"
subjectString = ""
' use mailmerge To create a new document for one record (defined by mm.DataSource.ActiveRecord)
mm.Destination = wdSendToNewDocument
mm.DataSource.FirstRecord = mm.DataSource.ActiveRecord
mm.DataSource.LastRecord = mm.DataSource.ActiveRecord
mm.Execute Pause:=False
' save the generated doc as a html file in the temp directory
Set singleDoc = ActiveDocument
' extract the "MailEnvelope" from the word doc, which is an outlook email containing the contents of the doc
Set outlookMail = singleDoc.MailEnvelope.Item
' run through all the fields in the mail merge data, when an email field is identified add the data To the appropriate field
For Each df In mm.DataSource.DataFields
' first check for the field being populated for the active record (row), only check if there is data provided
If Trim(df.Value) <> "" Then
' try matching the field name To accepted field names
Select Case StripToLcaseLetters(df.Name)
Case "to"
' add in the To address or addresses as they are presented in the data, if multiple To fields are present they will all be added, separated by a semicolon
If InStr(1, df.Value, "@", vbBinaryCompare) > 0 Then
toString = toString & ";" & df.Value
Else
errorString = errorString & vbCrLf & "Invalid email address in To field: " & df.Value
End If
Case "subject"
' add in the subject as it is presented in the data
If subjectString = "" Then
subjectString = df.Value
Else
errorString = "Second subject field found containing: " & df.Value
End If
Case "account"
' select the account from which the email is To be sent
' the account is identified by its full email address
' To identify the account, the code cycles through all the accounts available and selects a match
' if no data, or a non-matching email address is provided, then the default account is used
' note! not the same as send as - see below
For Each outlookAccount In outlookApp.Session.Accounts
If outlookAccount.SmtpAddress = df.Value Then Exit For
Next
If Not outlookAccount Is Nothing Then
Set outlookMail.SendUsingAccount = outlookAccount
Else
errorString = errorString & vbCrLf & "Account not found: " & df.Value
End If
End Select ' end test for the field names
End If ' end check for the data value being blank
Next df ' move on To the next record
' set the collected To, CC and bcc fields (some systems do not allow the To field To be read
' so we have To collect all To fields together first and then add them in one go
If Len(toString & ccString & bccString) = 0 Then errorString = errorString & vbCrLf & "No valid email addresses provided in To, CC and BCC fields"
If Len(subjectString) = 0 Then errorString = errorString & vbCrLf & "No subject provided"
outlookMail.To = toString
outlookMail.cc = ccString
outlookMail.BCC = bccString
outlookMail.Subject = subjectString
outlookMail.Display
' outlookMail.UserProperties.Add "Generator", olText, True
' outlookMail.UserProperties.Find("Generator").Value = "Imnoss"
' check the send flag and send or save
If Len(errorString) > 0 Then
singleDoc.Content.Text = "Errors found: " & errorString
outlookMail.BodyFormat = 1 'olFormatPlain
outlookMail.Subject = "**Errors in mail merge: " & subjectString
outlookMail.Close 0 'olSave
If Not contOnError Then
If MsgBox("Errors were found when creating email, email has been saved as a draft with subject """ & _
"**Errors in mail merge: " & subjectString & """ and a full list of errors in the body of the email" & vbLf & vbLf & _
"Press OK To continue with remaining records and Cancel To exit the macro.", vbOKCancel, "Errors in email") = vbCancel Then
Exit Sub
End If
contOnError = True
End If
ElseIf sendFlag Then
outlookMail.Send
Else
outlookMail.Close 0 'olSave
End If
Set outlookMail = Nothing
singleDoc.Close False
Set singleDoc = Nothing
' test if we have just created a document for the last record, if so we set lastRecordNum To zero To indicate that the loop should end, otherwise go To the next active record
If mm.DataSource.ActiveRecord >= lastRecordNum Then
lastRecordNum = 0
Else
mm.DataSource.ActiveRecord = wdNextRecord
End If
Loop
End Sub
Private Function StripToLcaseLetters(inputString As String) As String
' strips out all non-letters and converts To lowercase
Dim i As Long
Dim s As String
For i = 1 To Len(inputString)
Select Case Asc(Mid(inputString, i, 1))
Case 65 To 90, 97 To 122
s = s & Mid(inputString, i, 1)
End Select
Next i
StripToLcaseLetters = LCase(s)
End Function
