Option  Explicit
Private  Sub Application_Startup()
'IGNORE - This forces the VBA project to open and be accessible using automation at any point after startup
End  Sub

Public  Function mlaSendMail(strTo  As  String, _
                                strCC  As  String, _
                                strBCC  As  String, _
                                strSubject  As  String, _
                                strMessageBody  As  String, _
                                volBodyFormat  As  Variant, _
                                Optional strAttachments  As  String)  As  Boolean

On  Error  GoTo ErrorHandler:
     Dim MAPISession  As Outlook.NameSpace
     Dim MAPIFolder  As Outlook.MAPIFolder
     Dim MAPIMailItem  As Outlook.MailItem
     Dim oRecipient  As Outlook.Recipient
     Dim TempArray()  As  String
     Dim varArrayItem  As  Variant
     Dim strEmailAddress  As  String
     Dim strAttachmentPath  As  String
     Dim blnSuccessful  As  Boolean
     Dim objUserProperty  As  Object
                
     Set MAPISession = Application.Session

     If  Not MAPISession  Is  Nothing  Then

      'Logon to the MAPI session
     MAPISession.Logon , ,  True,  False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
      If  Not MAPIFolder  Is  Nothing  Then

         'Create a new mail item in the "Outbox" folder
         Set MAPIMailItem = MAPIFolder.Items. Add(olMailItem)
         If  Not MAPIMailItem  Is  Nothing  Then

          With MAPIMailItem

             'Create the recipients TO
                TempArray = Split(strTo, ";")
                 For  Each varArrayItem  In TempArray

                    strEmailAddress =  Trim(varArrayItem)
                     If  Len(strEmailAddress) > 0  Then
                         Set oRecipient = .Recipients. Add(strEmailAddress)
                        oRecipient. Type = olTo
                         Set oRecipient =  Nothing
                     End  If

                 Next varArrayItem

             'Create the recipients CC
                TempArray = Split(strCC, ";")
                 For  Each varArrayItem  In TempArray

                    strEmailAddress =  Trim(varArrayItem)
                     If  Len(strEmailAddress) > 0  Then
                         Set oRecipient = .Recipients. Add(strEmailAddress)
                        oRecipient. Type = olCC
                         Set oRecipient =  Nothing
                     End  If

                 Next varArrayItem

             'Create the recipients BCC
                TempArray = Split(strBCC, ";")
                 For  Each varArrayItem  In TempArray

                    strEmailAddress =  Trim(varArrayItem)
                     If  Len(strEmailAddress) > 0  Then
                         Set oRecipient = .Recipients. Add(strEmailAddress)
                        oRecipient. Type = olBCC
                         Set oRecipient =  Nothing
                     End  If

                 Next varArrayItem

             'Set the message SUBJECT
                .Subject = strSubject

             'Set the message BODY (HTML or plain text)

                 If volBodyFormat = OlBodyFormat.olFormatHTML  Then
                    .HTMLBody = strMessageBody
                    EmbedPictures MAPIMailItem, strMessageBody  ', strFileFullPath
                 Else
                    .Body = strMessageBody
                 End  If

             'Add any specified attachments
                TempArray = Split(strAttachments, ";")
                 For  Each varArrayItem  In TempArray

                    strAttachmentPath =  Trim(varArrayItem)
                     If  Len(strAttachmentPath) > 0  Then
                        .Attachments. Add strAttachmentPath
                     End  If

                 Next varArrayItem

            .Send  'No return value since the message will remain in the outbox if it fails to send

             Set MAPIMailItem =  Nothing

          End  With

         End  If

         Set MAPIFolder =  Nothing

      End  If

     MAPISession.Logoff

     End  If

     'If we got to here, then we shall assume everything went ok.
    blnSuccessful =  True

ExitRoutine:
     Set MAPISession =  Nothing
    mlaSendMail = blnSuccessful
     Exit  Function

ErrorHandler:
    blnSuccessful =  Err.Number
     Resume ExitRoutine
End  Function

Private  Sub EmbedPictures(ByRef robjMailItem  As  Object, _
        ByRef rstrHTMLBody  As  String, _
        Optional  ByVal vstrFilename  As  String)
Const cstrProcedure = "EmbedPictures"
Const olSave = 0
Const cstrCid = "cid:"

     Dim objHtmlDocument  As  Object
     Dim colImages        As  Object
     Dim objImage         As  Object
     Dim colSourceSrcs    As  Collection
     Dim colTargetSrcs    As  Collection
     Dim strSrc           As  String
     Dim strPath          As  String
     Dim lngIndex         As  Long
     Dim strHTMLBody      As  String
    
     On  Error  GoTo HandleError
    
     Set colSourceSrcs =  New  Collection
     Set colTargetSrcs =  New  Collection
    
     Set objHtmlDocument =  CreateObject("htmlfile")
    
    strHTMLBody = rstrHTMLBody
    
     With objHtmlDocument
        
        .Write strHTMLBody
        
         Set colImages = .Body.getElementsByTagName("img")
         For  Each objImage  In colImages
            strSrc = objImage.getAttribute("src", 2)  '2 - Returns the value exactly as it was set in script or in the source document.
             If  Not  StrComp( Left(strSrc, 5), "http:") = 0  Then
                strPath = CanonizePath(strSrc)
                 If IsRelative(strPath)  And  Not  Len(vstrFilename) = 0  Then
                    strPath = BuildPath(FilePath(vstrFilename), strPath)
                 End  If
                 If FileExists(strPath)  Then
                    colSourceSrcs. Add strSrc
                    colTargetSrcs. Add strPath
                 End  If
             End  If
         Next
     End  With
    
     If colTargetSrcs.Count = 0  Then  GoTo HandleExit
    
     With robjMailItem
         For lngIndex = 1  To colTargetSrcs.Count
            .Save        'Outlook Help: To ensure consistent results, always save an item before adding or removing objects in the Attachments collection of the item.
            .Attachments. Add colTargetSrcs(lngIndex)
         Next
        . Close olSave
     End  With
    
     For lngIndex = 1  To colSourceSrcs.Count
        strHTMLBody = Replace(strHTMLBody, colSourceSrcs(lngIndex), cstrCid & FileNameWithExt(colSourceSrcs(lngIndex)))
     Next

    robjMailItem.HTMLBody = strHTMLBody
  
HandleExit:
     Set objHtmlDocument =  Nothing
     Set colSourceSrcs =  Nothing
     Set colTargetSrcs =  Nothing
     Set colImages =  Nothing
     Set objImage =  Nothing

     Exit  Sub

HandleError:
     Resume HandleExit
End  Sub

Private  Function CanonizePath( ByVal strPath  As  String)  As  String    '+sg:01oct07
     Const mcstrURLFile = "file://"
     Const mcstrURLFile2 = mcstrURLFile & "/"
     If  StrComp( Left$(strPath,  Len(mcstrURLFile2)), mcstrURLFile2, vbTextCompare) = 0  Then
        strPath =  Mid$(strPath,  Len(mcstrURLFile2) + 1)
     ElseIf  StrComp( Left$(strPath,  Len(mcstrURLFile)), mcstrURLFile, vbTextCompare) = 0  Then
        strPath =  Mid$(strPath,  Len(mcstrURLFile) + 1)
     End  If
    strPath = Replace(strPath, "/", "\")
    strPath = Replace(strPath, "%20", " ")
    CanonizePath = strPath
End  Function

Public  Function IsRelative( ByVal vstrPath  As  String)  As  Boolean
    IsRelative =  Len(GetDriveName(vstrPath)) = 0
End  Function

Function FilePath(strPath  As  String)  As  String
    FilePath =  Left$(strPath, InStrRev(strPath, "\"))
End  Function

Function FileNameWithExt(strPath  As  String)  As  String
Dim FSO  As  Object
     Set FSO =  CreateObject("Scripting.FileSystemObject")
     If  Not FSO  Is  Nothing  Then
        FileNameWithExt = FSO.GetFileName(strPath)
     End  If
     Set FSO =  Nothing
End  Function

Private  Function BuildPath( ByVal vstrPath  As  String,  ByVal vstrName  As  String)  As  String
     If  Len(vstrPath) = 0  Or  Len(vstrPath) = 0  Then  Exit  Function
    BuildPath = IIf( Right(vstrPath, 1) = "\", vstrPath & vstrName, vstrPath & "\" & vstrName)
End  Function

Private  Function FileExists(strFileFullPath  As  String)  As  Boolean
     Dim lSize  As  Long
     On  Error  GoTo HandleError
    lSize = -1
     If  GetAttr(strFileFullPath)  And vbDirectory  Then  GoTo HandleExit
    lSize =  FileLen(strFileFullPath)
    FileExists = lSize > -1
HandleExit:
     Exit  Function
HandleError:
     Resume  Next
End  Function

Private  Function GetDriveName( ByVal FullPathFileName  As  String)  As  String
  Dim DriveName  As  String
     DriveName =  Left(FullPathFileName,  InStr(FullPathFileName, ":"))
     GetDriveName = DriveName
End  Function