the High Seas of Information Technology

Sending Email from Access or Excel using Outlook Automation

Sending email is a frequent necessity for Office programs. In order to "generalize" this procedure without piling up unused parameters I pass a dictionary object to a custom function. The keys for the dictionary items are the names the email elements (to, from, subject, body), and the values are, of course, matched to the same. This makes it easy to add new elements if you need them. In order to make the code as robust as possible, the routine is written to be case insensitive.

The best way to use this would be to put it into an addin or your "PERSONAL.XLS" workbook - this way you have one "outlook" function to maintain, no matter how many times you use it.

First, an example of using the code.

Private Sub Test_MySendMyEmail()
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.Add "to", Array("", "")
dic.Add "cc", ""
dic.Add "subject", "Test Email"
dic.Add "htmlbody", "<p>Test</p>"
dic.Add "attachment", "C:\myTemp\Book1.xlsx"
Call MySendMyEmail(dic)

End Sub

So, quite simple! And, here is the public function.

Public Function MySendMyEmail(ByRef arg As Scripting.Dictionary) As Byte
'This routines takes a dictionary with named elements:
'  "subject"
'  "to"
'  "cc"
'  "bcc"
'  "htmlbody"
'  "textbody" or "body"
'  "attachments" or "attachment"

'    *All dictionary items may be strings or variant/arrays of 1 or more dimensions
'            however, elements expected to be singular will only read the first element
'            of array arguments (i.e., subject, body).
'    *Case insensitive
'    *If an "htmlbody" is present then "textbody" or "body" is ignored

Dim vKey
Dim dic As Scripting.Dictionary
Dim vTo, vCC, vBCC, vAttachments
Dim sSubject As String, sHTMLBody As String, sBody As String

Const intMail_Item As Long = 0
Const intTO As Long = 1
Const intCC As Long = 2
Const intBCC As Long = 3
Dim a, i As Long
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Object
Dim objOutlookAttach As Object

On Error GoTo ErrHandler:
MySendMyEmail = 1
Set dic = CreateObject("Scripting.Dictionary")

    '//Part 1: Create a copy dictionary with lowercase keys
    For Each vKey In arg.Keys
dic.Add LCase(CStr(vKey)), arg(vKey)
Next vKey

    'Part 2: Extract arguments from dictionary
    If dic.Exists("subject") Then
If IsArray(dic("subject")) Then
sSubject = dic("subject")(LBound(dic("subject")))
sSubject = dic("subject")
End If
End If
'//Message body
    If dic.Exists("htmlbody") Then
If IsArray(dic.Item("htmlbody")) Then
sHTMLBody = dic.Item("htmlbody")(LBound(dic("htmlbody")))
sHTMLBody = dic.Item("htmlbody")
End If
ElseIf dic.Exists("textbody") Then
If IsArray(dic.Item("textbody")) Then
sBody = dic.Item("textbody")(LBound(dic("textbody")))
sBody = dic.Item("textbody")
End If
ElseIf dic.Exists("body") Then
If IsArray(dic.Item("body")) Then
sBody = dic.Item("body")(LBound(dic("body")))
sBody = dic.Item("body")
End If
End If
    If dic.Exists("to") Then
If IsArray(dic.Item("to")) Then
vTo = dic.Item("to")
vTo = Array(dic.Item("to"))
End If
End If
If dic.Exists("cc") Then
If IsArray(dic.Item("cc")) Then
vCC = dic.Item("cc")
vCC = Array(dic.Item("cc"))
End If
End If
If dic.Exists("bcc") Then
If IsArray(dic.Item("bcc")) Then
vBCC = dic.Item("bcc")
vBCC = Array(dic.Item("bcc"))
End If
End If
    If dic.Exists("attachments") Then
If IsArray(dic.Item("attachments")) Then
vAttachments = dic.Item("attachments")
vAttachments = Array(dic.Item("attachments"))
End If
ElseIf dic.Exists("attachment") Then
If IsArray(dic.Item("attachment")) Then
vAttachments = dic.Item("attachment")
vAttachments = Array(dic.Item("attachment"))
End If
End If
    'Part 3: Create Outlook instance and send the email
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(intMail_Item)
With objOutlookMsg
        If sSubject <> "" Then
.Subject = sSubject
End If
        If Not IsEmpty(vTo) Then
For i = 0 To UBound(vTo)
Set objOutlookRecip = .Recipients.Add(vTo(i))
objOutlookRecip.Type = intTO
Next i
End If
        If Not IsEmpty(vCC) Then
For i = 0 To UBound(vCC)
Set objOutlookRecip = .Recipients.Add(vCC(i))
objOutlookRecip.Type = intCC
Next i
End If
        If Not IsEmpty(vBCC) Then
For i = 0 To UBound(vBCC)
Set objOutlookRecip = .Recipients.Add(vBCC(i))
objOutlookRecip.Type = intBCC
Next i
End If
        If sHTMLBody <> "" Then
.HTMLBody = sHTMLBody
.Body = sBody
End If
        If Not IsEmpty(vAttachments) Then
For i = 0 To UBound(vAttachments)
Set objOutlookAttach = .Attachments.Add(vAttachments(i))
Next i
End If
' Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
End With
MySendMyEmail = 0
On Error Resume Next
Set objOutlook = Nothing
Exit Function

Resume My_Exit:
End Function

last modified: 28-Jan-2015
Copyright © 2015