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