'---------------------------------------------------------------------------------------
' Procedure : SendHTMLEmail
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Automate Outlook to send an HTML email with or without attachments
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding version -> None required
' Early Binding version -> Ref to Microsoft Outlook XX.X Object Library
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTo : To Recipient email address string (semi-colon separated list)
' sSubject : Text string (HTML) to be used as the email subject line
' sBody : Text string to be used as the email body (actual message)
' bEdit : True/False whether or not you wish to preview the email before sending
' vCC : CC Recipient email address string (semi-colon separated list)
' vBCC : BCC Recipient email address string (semi-colon separated list)
' vAttachments : Array of attachment (complete file paths with
' filename and extensions)
' vAccount : Name of the Account to use for sending the email (normally the e-mail adddress)
' if no match is found it uses the default account
'
' Usage:
' ~~~~~~
' Call SendHTMLEmail("abc@xyz.com", "My Subject", "<p>My <b>body</b>.</p>", True)
' Call SendHTMLEmail("abc@xyz.com;def@wuv.ca;", "My Subject", "<p>My <b>body</b>.</p>", True)
' Call SendHTMLEmail("abc@xyz.com", "My Subject", "<p>My <b>body</b>.</p>", True, , _
' Array("C:\Temp\Table2.txt"))
' Call SendHTMLEmail("abc@xyz.com", "My Subject", "<p>My <b>body</b>.</p>", True, , _
' Array("C:\Temp\Table2.txt", "C:\Temp\Supplier List.txt"))
' Call SendHTMLEmail("abc@xyz.com", "My Subject", "<p>My <b>body</b>.</p>", True, , _
' Array("C:\Temp\Table2.txt", "C:\Temp\Supplier List.txt"), _
' "cde@uvw.com")
' Call SendHTMLEmail("abc@xyz.com", "My Subject", "<p>My <b>body</b>.</p>", True, , _
' Split("C:\Temp\Table2.txt,C:\Temp\Supplier List.txt", ","), _
' "cde@uvw.com")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2007-11-16 Initial Release
' 2 2017-02-15 Added retention of default e-mail signature
' Added conditional compiler directives for early and
' late binding
' 3 2019-01-20 Updated Copyright
' Added usage examples
' Added sAccount option
' 4 2019-09-06 Updated the handling of sTo and sBCC to split e-mail
' addresses into individual recipients and
' improved error reporting for unresolvable e-mail
' addresses per an issue flagged by InnVis (MSDN)
' 5 2020-03-12 Bugs fixes (missing declarations) from comments by
' S.A.Marshall in answers forum
' Added CC to function
' 6 2020-12-08 Proper parsing of .HTMLBody so proper HTML is
' generated
' 7 2021-02-19 Added Split() example to usage examples
'---------------------------------------------------------------------------------------
Function SendHTMLEmail(ByVal sTo As String, _
ByVal sSubject As String, _
ByVal sBody As String, _
ByVal bEdit As Boolean, _
Optional vCC As Variant, _
Optional vBCC As Variant, _
Optional vAttachments As Variant, _
Optional vAccount As Variant) As Boolean
On Error GoTo Error_Handler
' #Const EarlyBind = 1 'Use Early Binding
#Const EarlyBind = 0 'Use Late Binding
#If EarlyBind Then
Dim oOutlook As Outlook.Application
Dim oOutlookMsg As Outlook.MailItem
Dim oOutlookInsp As Outlook.Inspector
Dim oOutlookRecip As Outlook.Recipient
Dim oOutlookAttach As Outlook.Attachment
Dim oOutlookAccount As Outlook.Account
#Else
Dim oOutlook As Object
Dim oOutlookMsg As Object
Dim oOutlookInsp As Object
Dim oOutlookRecip As Object
Dim oOutlookAttach As Object
Dim oOutlookAccount As Object
Const olMailItem = 0
#End If
Dim sHTML As String
Dim aHTML As Variant
Dim aSubHTML As Variant
Dim aRecip As Variant
Dim I As Integer
Set oOutlook = CreateObject("Outlook.Application")
Set oOutlookMsg = oOutlook.CreateItem(olMailItem)
With oOutlookMsg
'Account to use for sending, if specified, otherwise use default
If Not IsMissing(vAccount) Then
For Each oOutlookAccount In oOutlook.Session.Accounts
If oOutlookAccount = vAccount Then
Set oOutlookMsg.SendUsingAccount = oOutlookAccount
End If
Next
End If
DoCmd.SetWarnings False
' .display 'Had to move this command here to resolve a bug only existent in Access 2016!
'TO
aRecip = Split(sTo, ";")
For I = 0 To UBound(aRecip)
If Trim(aRecip(I) & "") <> "" Then
Set oOutlookRecip = .Recipients.Add(aRecip(I))
oOutlookRecip.Type = 1
End If
Next I
' .display 'Had to move this command here to resolve a bug only existent in Access 2016!
'CC
If Not IsMissing(vCC) Then
aRecip = Split(vCC, ";")
For I = 0 To UBound(aRecip)
If Trim(aRecip(I) & "") <> "" Then
Set oOutlookRecip = .Recipients.Add(aRecip(I))
oOutlookRecip.Type = 2
End If
Next I
End If
'BCC
If Not IsMissing(vBCC) Then
aRecip = Split(vBCC, ";")
For I = 0 To UBound(aRecip)
If Trim(aRecip(I) & "") <> "" Then
Set oOutlookRecip = .Recipients.Add(aRecip(I))
oOutlookRecip.Type = 3
End If
Next I
End If
.subject = sSubject
' Set oOutlookInsp = .GetInspector 'Retains the signature if applicable
sHTML = .HTMLBody
aHTML = Split(sHTML, "<body")
aSubHTML = Split(aHTML(1), ">")
sHTML = aHTML(0) & "<body" & aSubHTML(0) & ">" & _
sBody & _
Right(aHTML(1), Len(aHTML(1)) - Len(aSubHTML(0) & ">"))
.HTMLBody = sHTML
.Importance = 2 'Importance Level 0=Low,1=Normal,2=High
' Add attachments to the message.
If Not IsMissing(vAttachments) Then
If IsArray(vAttachments) Then
For I = LBound(vAttachments) To UBound(vAttachments)
If vAttachments(I) <> "" And vAttachments(I) <> "False" Then
Set oOutlookAttach = .Attachments.Add(vAttachments(I))
End If
Next I
Else
If vAttachments <> "" Then
Set oOutlookAttach = .Attachments.Add(vAttachments)
End If
End If
End If
For Each oOutlookRecip In .Recipients
If Not oOutlookRecip.Resolve Then
'You may wish to make this a MsgBox! to show the user that there is a problem
Debug.Print "Could not resolve the e-mail address: ", oOutlookRecip.Name, oOutlookRecip.Address, _
Switch(oOutlookRecip.Type = 1, "TO", _
oOutlookRecip.Type = 2, "CC", _
oOutlookRecip.Type = 3, "BCC")
bEdit = True 'Problem so let display the message to the user so they can address it.
End If
Next
' If bEdit = True Then 'Choose btw transparent/silent send and preview send
' '.Display
' Else
.Send
SendHTMLEmail = True
' End If
End With
Error_Handler_Exit:
On Error Resume Next
If Not oOutlookAccount Is Nothing Then Set oOutlookAccount = Nothing
If Not oOutlookAttach Is Nothing Then Set oOutlookAttach = Nothing
If Not oOutlookRecip Is Nothing Then Set oOutlookRecip = Nothing
If Not oOutlookInsp Is Nothing Then Set oOutlookInsp = Nothing
If Not oOutlookMsg Is Nothing Then Set oOutlookMsg = Nothing
If Not oOutlook Is Nothing Then Set oOutlook = Nothing
Exit Function
Error_Handler:
SendHTMLEmail = False
If Err.Number = "287" Then
MsgBox "You clicked No to the Outlook security warning. " & _
"Rerun the procedure and click Yes to access e-mail " & _
"addresses to send your message. For more information, " & _
"see the document at http://www.microsoft.com/office" & _
"/previous/outlook/downloads/security.asp."
Else
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: SendHTMLEmail" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
End If
Resume Error_Handler_Exit
End Function
