Code:
Option Explicit
Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.Attachment
Dim lngLoop As Long
Dim strSignature As String
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Function
End If
'Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
End If
'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
'Add the To recipient(s) to the message.
For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
objOutlookRecip.Type = 1 'olTO
End If
Next lngLoop
'Add the CC recipient(s) to the message.
For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
objOutlookRecip.Type = 2 'olCC
End If
Next lngLoop
'Add the BCC recipient(s) to the message.
For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
objOutlookRecip.Type = 3 'olBCC
End If
Next lngLoop
'Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = 2 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
'Add attachments to the message.
If Not strAttachmentPath = "" Then
For lngLoop = LBound(Split(strAttachmentPath, ";")) To UBound(Split(strAttachmentPath, ";"))
If Len(Dir(Trim(Split(strAttachmentPath, ";")(lngLoop)))) <> 0 Then
Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, ";")(lngLoop)))
Else
MsgBox "Unable to find the specified attachment. Sending mail anyway."
End If
Next lngLoop
End If
If blnSignature Then
'Win XP
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
If Dir(strSignature) = "" Then
'Win 7
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
End If
End If
If Dir(strSignature) <> "" Then
strSignature = GetBoiler(strSignature)
Else
strSignature = ""
End If
'MsgBox .htmlbody
.HTMLBody = .HTMLBody & strSignature
'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
'Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Function
Function RangetoHTML(rng As Range)
'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim strTempFile As String
Dim wbkTemp As Workbook
strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a workbook to receive the data.
rng.Copy
Set wbkTemp = Workbooks.Add(1)
With wbkTemp.Sheets(1)
With .Cells(1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
.Select
End With
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Err.Clear: On Error GoTo 0
End With
'Publish the sheet to an .htm file.
With wbkTemp.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strTempFile, _
Sheet:=wbkTemp.Sheets(1).Name, _
Source:=wbkTemp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the .htm file into the RangetoHTML subroutine.
RangetoHTML = GetBoiler(strTempFile)
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close wbkTemp
wbkTemp.Close savechanges:=False
'Delete the htm file.
Kill strTempFile
Set wbkTemp = Nothing
End Function
Function GetBoiler(ByVal strFile As String) As String
'May not be supported in MAC
Dim objFSO As Object
Dim objTextStream As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
GetBoiler = objTextStream.ReadAll
objTextStream.Close
Set objFSO = Nothing
Set objTextStream = Nothing
End Function
Reply With Quote
Bookmarks