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("recipient1@example.com", "recipient2@example.com")
    dic.Add "cc", "recipient3@example.com"
    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"

'Notes:
'    *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
    '//Subject
    If dic.Exists("subject") Then
        If IsArray(dic("subject")) Then
            sSubject = dic("subject")(LBound(dic("subject")))
        Else
            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")))
        Else
            sHTMLBody = dic.Item("htmlbody")
        End If
    ElseIf dic.Exists("textbody") Then
        If IsArray(dic.Item("textbody")) Then
            sBody = dic.Item("textbody")(LBound(dic("textbody")))
        Else
            sBody = dic.Item("textbody")
        End If
    ElseIf dic.Exists("body") Then
        If IsArray(dic.Item("body")) Then
            sBody = dic.Item("body")(LBound(dic("body")))
        Else
            sBody = dic.Item("body")
        End If
    End If
    '//Recipients
    If dic.Exists("to") Then
        If IsArray(dic.Item("to")) Then
            vTo = dic.Item("to")
        Else
            vTo = Array(dic.Item("to"))
        End If
    End If
    If dic.Exists("cc") Then
        If IsArray(dic.Item("cc")) Then
            vCC = dic.Item("cc")
        Else
            vCC = Array(dic.Item("cc"))
        End If
    End If
    If dic.Exists("bcc") Then
        If IsArray(dic.Item("bcc")) Then
            vBCC = dic.Item("bcc")
        Else
            vBCC = Array(dic.Item("bcc"))
        End If
    End If
    '//Attachments
    If dic.Exists("attachments") Then
        If IsArray(dic.Item("attachments")) Then
            vAttachments = dic.Item("attachments")
        Else
            vAttachments = Array(dic.Item("attachments"))
        End If
    ElseIf dic.Exists("attachment") Then
        If IsArray(dic.Item("attachment")) Then
            vAttachments = dic.Item("attachment")
        Else
            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

        '//SUBJECT
        If sSubject <> "" Then
            .Subject = sSubject
        End If

        '//TO
        If Not IsEmpty(vTo) Then
            For i = 0 To UBound(vTo)
                Set objOutlookRecip = .Recipients.Add(vTo(i))
                 objOutlookRecip.Type = intTO
            Next i
        End If

        '//CC
        If Not IsEmpty(vCC) Then
            For i = 0 To UBound(vCC)
                Set objOutlookRecip = .Recipients.Add(vCC(i))
                 objOutlookRecip.Type = intCC
            Next i
        End If

        '//BCC
        If Not IsEmpty(vBCC) Then
            For i = 0 To UBound(vBCC)
                Set objOutlookRecip = .Recipients.Add(vBCC(i))
                 objOutlookRecip.Type = intBCC
            Next i
        End If

        '//MESSAGE TEXT
        If sHTMLBody <> "" Then
            .HTMLBody = sHTMLBody
        Else
            .Body = sBody
        End If

        '//ATTACHMENTS
        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
            objOutlookRecip.Resolve
        Next

        .Save
        .Send

    End With
    '-----------------------------------------------------


    MySendMyEmail = 0


My_Exit:
On Error Resume Next
Set objOutlook = Nothing
Exit Function

ErrHandler:
Resume My_Exit:
End Function

Sending Email from Access or Excel using Outlook Automation

last modified: 28-Jan-2015Copyright © 2015

last modified: 28-Jan-2015
Copyright © 2015