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 ammolSendMail(strTo  As  String, _
                                strCC 
As  String, _
                                strBCC 
As  String, _
                                strSubject 
As  String, _
                                strMessageBody 
As  String, _
                                volBodyFormat 
As  Variant, _
                                Optional strAttachments 
As  String, _
                                Optional strFileFullPath 
As  String, _
                                Optional strSavedDocumentFullName 
As  String, _
                                Optional SavedDocumentFormat 
As  Long, _
                                Optional strFolderEmailSent 
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

            
If Len(strSavedDocumentFullName) > 0  Then
                 Set objUserProperty = .UserProperties.Add("Path", olText)
                objUserProperty.Value = strSavedDocumentFullName
                
Set objUserProperty = .UserProperties.Add("Format", olNumber)
                objUserProperty.Value = SavedDocumentFormat
            
End  If

             If Len(strFolderEmailSent) > 0  Then
                 Set objUserProperty = .UserProperties.Add(cstrFolderEmailSent, olText)
                objUserProperty.Value = strFolderEmailSent
            
End  If
            
            .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
    ammolSendMail = 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 StringAs 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 StringAs Boolean
    IsRelative = Len(GetDriveName(vstrPath)) = 0
End Function

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

Function FileNameWithExt(strPath As StringAs 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 StringByVal vstrName As StringAs 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 StringAs 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 StringAs String
 Dim DriveName As String
     DriveName = Left(FullPathFileName, InStr(FullPathFileName, ":"))
     GetDriveName = DriveName
End Function