VBA Modules: modEmail v1.09

Read this for full information on these modules

This deadly simple piece of code will send an email via Outlook.

Original source from Microsoft support site

'modEmail
'v1.09 2013-11-12 10:36

'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   TJP@tomparish.me.uk
'   http://baldywrittencod.blogspot.com
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'===========================================================================
' modEmail
'===========================================================================
'   Routines for sending emails.

'===========================================================================
' Additional modules required:
'===========================================================================
'   None

'===========================================================================
' Additional References required:
'===========================================================================
'   None

'===========================================================================
' External applications required:
'===========================================================================
'   None

'=========================================================================
' VERSION HISTORY
'=========================================================================
'   v1.09   bugfix - AttachmentPaths as string <> ""
'           upgrade from v1.08 essential
'*************************************************************************
'   v1.08   bugfix - dim AttachmentPaths as string
'*************************************************************************
'   v1.07   up to 3 attachments
'   v1.06   bugfix - multiple To/CC/BCC didn't resolve if separated by ";"
'   v1.05   bugfix - multiple To/CC/BCC recipients didn't resolve
'*************************************************************************
'   v1.04   bugfix - upgrade advised
'   v1.03   bugfix - upgrade essential
'*************************************************************************
'   v1.02a  annotations only
'   v1.02   added cDefaultEmail
'   v1.01   late bound references
'   v1.00   SendEmail: code adapted from original source
'           http://support.microsoft.com/kb/161088

Option Explicit

'default email address for Trigger Failure and if recipient is specified as "" (mainly for testing)
Public Const cDefaultEmail As String = "bpm.gb@dhl.com"  'v1.04

Private Enum olDefaultFolders
    olFolderCalendar = 9
    olFolderContacts = 10
    olFolderDeletedItems = 3
    olFolderDrafts = 16
    olFolderInbox = 6
    olFolderJournal = 11
    olFolderJunk = 23
    olFolderNotes = 12
    olFolderOutbox = 4
    olFolderSentMail = 5
    olFolderTasks = 13
    olPublicFoldersAllPublicFolders = 18
    olFolderConflicts = 19
    olFolderLocalFailures = 21
    olFolderServerFailures = 22
    olFolderSyncIssues = 20
End Enum

Private Enum olItemType
    olAppointmentItem = 1
    olContactItem = 2
    olDistributionListItem = 7
    olJournalItem = 4
    olMailItem = 0
    olNoteItem = 5
    olPostItem = 6
    olTaskItem = 3
End Enum

Function SendEmail(ByVal Email_Recipient As String, Optional ByVal Email_RecipientCC As String _
    , Optional ByVal Email_RecipientBCC As String, Optional ByVal Email_Subject As String _
    , Optional ByVal Email_BodyText As String, Optional ByVal DisplayMsg As Boolean = False _
    , Optional AttachmentPath As String, Optional AttachmentPath2 As String, Optional AttachmentPath3 As String _
    ) As Byte
'v1.09 2013-11-12 10:36
'results: 0=success, 1=fail
'original source: http://support.microsoft.com/kb/161088
'v1.05 bugfix: http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients

On Error GoTo SendEmailError

Dim objOutlook As Object        'Outlook.Application
'Dim objOutlookMsg 'As Object     'Outlook.MailItem
Dim objOutlookRecip As Object   'Outlook.Recipient
Dim objOutlookAttach As Object  'Outlook.Attachment
'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients
Dim EmailList As Variant, NumEmails As Long, AddEmailLoop As Long

' Create the Outlook session.
If InStr(Application.Name, "Outlook") = 0 Then
    Set objOutlook = CreateObject("Outlook.Application")
Else
    Set objOutlook = Application
End If

' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem
Set objOutlook = objOutlook.CreateItem(0) 'olMailItem

'With objOutlookMsg
With objOutlook
    ' Add the To recipient(s) to the message.
    If Email_Recipient = "" Then
        Set objOutlookRecip = .Recipients.Add(cDefaultEmail)  'for testing/blunt force only
    Else
    'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients
        Email_Recipient = Replace(Email_Recipient, ";", "; ")  'v1.06
        EmailList = Split(Email_Recipient, ";")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 1 'olTo
            objOutlookRecip.Resolve
        Next
    End If

    ' Add the CC recipient(s) to the message.
    If Email_RecipientCC <> "" Then
        Email_RecipientCC = Replace(Email_RecipientCC, ";", "; ")  'v1.06
        EmailList = Split(Email_RecipientCC, "; ")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 2 'olCC
            objOutlookRecip.Resolve
        Next
    End If
  
   ' Add the BCC recipient(s) to the message.
    If Email_RecipientBCC <> "" Then
        Email_RecipientBCC = Replace(Email_RecipientBCC, ";", "; ")  'v1.06
        EmailList = Split(Email_RecipientBCC, "; ")
        NumEmails = UBound(EmailList)
        For AddEmailLoop = 0 To NumEmails
            Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))
            objOutlookRecip.Type = 3 'olBCC
            objOutlookRecip.Resolve
        Next
    End If

   ' Set the Subject, Body, and Importance of the message.
   .Subject = Email_Subject
   .Body = Email_BodyText & vbCrLf & vbCrLf
   .Importance = 2  'olImportanceHigh  'High importance

   ' Add attachments to the message.
   If AttachmentPath <> "" Then  'v1.09
       Set objOutlookAttach = .Attachments.Add(AttachmentPath)
   End If
   If AttachmentPath2 <> "" Then  'v1.07
       Set objOutlookAttach = .Attachments.Add(AttachmentPath2)
   End If
   If AttachmentPath3 <> "" Then
       Set objOutlookAttach = .Attachments.Add(AttachmentPath3)
   End If

   ' Resolve each Recipient's name.  'v1.06 now resolved separately on addition
'   For Each objOutlookRecip In .Recipients
'       objOutlookRecip.Resolve
'   Next

   ' Should we display the message before sending?
   If DisplayMsg Then
       .Display
   Else
       .Save
       .Send
   End If
End With

Set objOutlook = Nothing
SendEmail = 0  'no error
Exit Function

SendEmailError:
SendEmail = 1  'general failure
End Function