Send html Outlook Email, options for signature, attach, embed image plus many more

nikalopolis · Mar 11, 2008

sorry, ignore the first post it sent before i was ready

nikalopolis · Mar 11, 2008

Sample code to send email from Outlook, can include signature, attached file, embedded image, cc, bcc, setting the replyto email address

I regularly need to send emails via outlook and have done a lot of work over the last few months to improve the routine that i use.
I thought i would post it here for some feedback and to assist others (when we have finished kicking it about, it can go in the repository.

tested in Office 2003 running on XP

References Required
Microsoft Outlook
Microsoft Word

Main Function

Code:

Public Function SendMessage(varTo As Variant, strSubject As String, strBody As String, _
     bolAutoSend As Boolean, bolSaveInOutbox As Boolean, bolAddSignature As Boolean, _
    Optional varCC As Variant, Optional varBCC As Variant, Optional varReplyTo As Variant, Optional varAttachmentPath As Variant, Optional varImagePath As Variant, Optional varHtmlFooter As Variant) As Boolean
'=================================================================
'
'varto: a string of email addresses, multiples delimted by semi-colon
'strSubject: subject line for the email
'strBody: body of the email, must be wrapped in <html> </html> tags, and optionally any other formatting tags
'bolAutoSend: determines whether email is sent automatically or displayed to the user
'bolSaveInOutbox: determines if the message is saved in the outbox
'boladdsignature: determines if the user's default signature is added to the outgoing email
'varCC: (Optional) CC email addresses, multiples delimited by semi-colon
'varBCC: (Optional) BCC email addresses, multiples delimited by semi-colon
'varReplyTo (Optional) If specified sets the reply to email address, multiples delimited by semi-colon
'varAttachmentPath: (Optional) If specified attaches the file
'varImagePath: (Optional) If specified embeds the image in the body of the email
'varHtmlFooter: (Optional) If specifed, inserts an html file as a footer to the message.
'ASSUMPTIONS: Outlook, HTML message format, Word is the default editor
'When performing some of the optional steps the message is constructed in the following order
'signature then embedded image then footer then body text, so the actual email would read as follows
'body text, footer, embedded image, signature
'=================================================================
On Error GoTo HandleError

Dim i As Integer
Dim strtempfile As String
Dim strmsg As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objInsp As Outlook.Inspector
Dim objword As Word.Application
Dim objdoc As Word.Document
Dim objrange As Word.Range

SendMessage = False

Set objOutlook = New Outlook.Application                                'Create the Outlook session.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)                   'Create the message.

strBody = ReplaceCRLFwithBR(strBody)                                    'Replace any vbcrlf with <br>

If (InStr(strBody, "<font") = 0) Or (InStr(strBody, "<html>") = 0) Then                              'if no <html> and <font> tags then wrap the body of the message with these tags
    strBody = FormatAsHtml(strBody)
End If

With objOutlookMsg
    
    If Not IsMissing(varTo) Then
        If varTo <> "" And Not IsNull(varTo) Then
            For i = 1 To CountCSWords(varTo)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varTo, i))               'Add the TO recipient(s) to the message.
                objOutlookRecip.Type = olTo
            Next i
        End If
    End If

    If Not IsMissing(varCC) Then
        If varCC <> "" And Not IsNull(varCC) Then
            For i = 1 To CountCSWords(varCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varCC, i))                  'Add the cc recipient(s) to the message.
                objOutlookRecip.Type = olCC
            Next i
        End If
    End If
  
    If Not IsMissing(varBCC) Then
        If varBCC <> "" And Not IsNull(varBCC) Then
            For i = 1 To CountCSWords(varBCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varBCC, i))                 'Add the bcc recipient(s) to the message.
                objOutlookRecip.Type = olBCC
            Next i
        End If
    End If
    
    If Not IsMissing(varReplyTo) Then
        If varReplyTo <> "" And Not IsNull(varReplyTo) Then
            For i = 1 To CountCSWords(varReplyTo)
                Set objOutlookRecip = .ReplyRecipients.Add(GetCSWord(varReplyTo, i))        'Add the bcc recipient(s) to the message.
            Next i
        End If
    End If
    
    
    If (Not IsMissing(varAttachmentPath)) Then                                                      'if attachment is specified
        If (varAttachmentPath <> "") And (Not IsNull(varAttachmentPath)) Then                       'check it is valid
            If Dir(varAttachmentPath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then    'check the file actually exists
                Set objOutlookAttach = .Attachments.Add(CStr(varAttachmentPath))                      'Add attachments to the message.
            End If
        End If
    End If
    
    
    .Subject = strSubject               'Set the Subject of the message.

    .BodyFormat = olFormatHTML          'set format to html
    
    If bolAddSignature Or Not IsMissing(varImagePath) Or Not IsMissing(varHtmlFooter) Then  'if signature or embedded image or html footer
        Set objInsp = objOutlookMsg.GetInspector                                            'this causes the default signature to be added to the message
        Set objdoc = objInsp.WordEditor
        If objdoc Is Nothing Then
            strmsg = "Outlook must use Word as the email editor. Follow these instructions to fix the problem." & vbCrLf & vbCrLf & _
                "Tools>Options" & vbCrLf & "Then select 'Mail Format' tab" & vbCrLf & "Ensure Use Microsoft Office Word 2003 to edit e-mail messages."
            MsgBox strmsg
            objOutlookMsg.Close olDiscard
            GoTo SendMessage_Done
        End If
            
        Set objword = objdoc.Application
        
        If bolAddSignature = False Then         'If the user had a signature it would have been applied, if we dont want it then we need to delete it here
            objdoc.Range.Delete
        End If
            
        If Not IsMissing(varImagePath) Then
            If varImagePath <> "" And Not IsNull(varImagePath) Then
                If Dir(varImagePath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    On Error Resume Next
                    .Display                                                                        'Seems like word document must be visible before you can use addpicture method
                    If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
                        MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
                        .Close olDiscard
                        GoTo SendMessage_Done
                    End If
                    objword.WindowState = wdWindowStateMinimize                                     'minimize word application so user does not see mail being created
                    Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message again
                    objrange.InsertBefore vbCrLf
                    objdoc.InlineShapes.AddPicture FileName:=varImagePath, LinkToFile:=False, SaveWithDocument:=True, Range:=objrange
                End If
            End If
        End If

        If Not IsMissing(varHtmlFooter) Then
            If varHtmlFooter <> "" And Not IsNull(varHtmlFooter) Then
                If Dir(varHtmlFooter, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message
                    objrange.InsertFile varHtmlFooter, , , False, False   'insert the html from the external file
                End If
            End If
        End If
        
        strtempfile = Environ("temp") & Format(Now(), "yyyymmddhhnnss") & ".htm"        'generate temp filename
        Set objrange = objdoc.Range(start:=0, End:=0)                                   'goto start of message again
        CreateTextFile strtempfile, strBody                                             'save the bodytext as a temporary htm file
        objrange.InsertFile strtempfile, , , False, False                               'insert the htm file into the body of the message
        Kill strtempfile                                                                'delete temp file
        
        objdoc.SpellingChecked = True                                                   'doesnt matter for autosend, but helps the user if the message is being displayed
    Else
        .HTMLBody = strBody
    End If
    
    If bolSaveInOutbox = False Then             'if message not to be saved after sending
        .DeleteAfterSubmit = True               'specify that it should be deleted
    End If
        
    If (bolAutoSend = True) And (.Recipients.Count > 0) Then        'check that there is at least 1 recipient before trying to autosend
        .Send
    Else
        Err = 0
        On Error Resume Next
        .Display                    'Attempt to display the message
        If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
            MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
            .Close olDiscard
            GoTo SendMessage_Done
        End If
    End If
End With
  
SendMessage = True

SendMessage_Done:
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set objInsp = Nothing
    Set objword = Nothing
    Set objdoc = Nothing
    Set objrange = Nothing
    Exit Function

HandleError:
    MsgBox Err.Number & ":" & Err.Description, vbCritical
    Resume SendMessage_Done

End Function

Additional functions that are required

Code:

Public Function ReplaceCRLFwithBR(ByVal strText) As String
'=================================================================
'Replace all vbcrlf with <br> to keep line breaks in html emails
'=================================================================

strText = Replace(strText, Chr(13), "<br>")
strText = Replace(strText, Chr(10), "")

ReplaceCRLFwithBR = strText


End Function

Public Function FormatAsHtml(ByVal str) As String
'=================================================================
'Wraps a string in html tags
'=================================================================

FormatAsHtml = "<html><font face=""arial"" size=""2"">" & str & "</font></html>"

End Function

Public Function GetCSWord(ByVal s, Indx As Integer, Optional strdelimiter = ";") As String
'=================================================================
'Returns the nth word in a specific field
'=================================================================

On Error Resume Next

GetCSWord = Split(s, strdelimiter)(Indx - 1)

End Function

Function CountCSWords(ByVal str, Optional strdelimiter = ";") As Integer
'=================================================================
'Counts the words in the delimited string
'=================================================================

Dim WC As Integer, Pos As Integer

If VarType(str) <> 8 Or Len(str) = 0 Then
    CountCSWords = 0
    Exit Function
End If
WC = 1
Pos = InStr(str, strdelimiter)
Do While Pos > 0
    WC = WC + 1
    Pos = InStr(Pos + 1, str, strdelimiter)
Loop

CountCSWords = WC
    
End Function


Public Sub CreateTextFile(strFullPath As String, strText As String)
'=================================================================
'Creates a text file with the specified file name containing the supplied text
'=================================================================

Dim fso As Object
Dim MyFile As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(strFullPath, True)          'Creates file, existing file will be overwritten
MyFile.WriteLine (strText)                                  'writes string to the file
MyFile.Close                                                'close the file


End Sub

Public Function GetTextFile(ByVal strFile As String) As String
'=================================================================
'Returns a string that contains the contents of the specified file
'=================================================================
   
Dim fso As Object
Dim ts As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(strFile).OpenAsTextStream(1, -2)       'Open the file ForReading, Use system default for file format
GetTextFile = ts.readall                                    'Read the contents of the file
ts.Close                                                    'Close the file


End Function

put this in command button to test it

Code:

Private Sub cmdSendTestMessage_Click()

Dim varTo As Variant
Dim strSubject As String
Dim strBody As String
Dim bolAutoSend As Boolean
Dim bolSaveInOutbox As Boolean
Dim bolAddSignature As Boolean
Dim varCC As Variant
Dim varBCC As Variant
Dim varReplyTo As Variant
Dim varAttachmentPath As Variant
Dim varImagePath As String
Dim varHtmlFooter As Variant

varTo = "someone@somedomain.com"
strSubject = "message subject"
strBody = "message body"
bolAutoSend = True
bolSaveInOutbox = True
bolAddSignature = True
varCC = "someoneelse@somedomain.com"
varBCC = "fred@somedomain.com"
varReplyTo = "tom@somedomain.com"
varAttachmentPath = "C:\file.xls"
varImagePath = "C:\image.png"
varHtmlFooter = "C:\footer.htm"


SendMessage varTo, strSubject, strBody, bolAutoSend, bolSaveInOutbox, bolAddSignature, varCC:=varCC, varBCC:=varBCC, varReplyTo:=varReplyTo, varAttachmentPath:=varAttachmentPath, varImagePath:=varImagePath, varHtmlFooter:=varHtmlFooter


End Sub

would be interested to see what people think.

shall i put a sample up as a zip??

tl mike · Mar 11, 2008

Actually A zipped version would be great! Right now I dont need it because I am not that far on my db but once I have everything in place it would be a great addition!!!

Darth Vodka · Apr 24, 2008

nikalopolis said:
would be interested to see what people think.

looks good, i have a similar thing and was wondering how to switch that damn signature on

GetInspector, that's not obvious!

oh and i have written some code to turn a SQL string into a html file that i use with it

Code:

'---------------------------------------------------------------------------------------
' Procedure : RecordsetToHTML
' Author    : DarthVodka
' Date      : 23/04/08
' Purpose   : to convert any given recordset into a HTML file with a table. to enable HTML emailing
'---------------------------------------------------------------------------------------
'
Public Function RecordsetToHTML(ByVal strSQL As String, _
                                Optional ByVal strFont As String = "Verdana", _
                                Optional ByVal intFontSize As Integer = 10, _
                                Optional ByVal strPreceeding As String = "", _
                                Optional ByVal strProceeding As String = "") As String

    Dim db          As DAO.Database
    Dim rs          As DAO.Recordset
    Dim fld         As DAO.Field
    
    RecordsetToHTML = "<html>" & vbCr
    RecordsetToHTML = RecordsetToHTML & "<head>" & vbCr
    RecordsetToHTML = RecordsetToHTML & "<STYLE TYPE=""text/css"">" & vbCr
    RecordsetToHTML = RecordsetToHTML & "<!--" & vbCr
    RecordsetToHTML = RecordsetToHTML & "TD{font-family: " & strFont & "; font-size: " & intFontSize & "pt;}" & vbCr
    RecordsetToHTML = RecordsetToHTML & "--->" & vbCr
    RecordsetToHTML = RecordsetToHTML & "</STYLE>" & vbCr
    RecordsetToHTML = RecordsetToHTML & "</head>" & vbCr
    RecordsetToHTML = RecordsetToHTML & "<body>" & vbCr
    RecordsetToHTML = RecordsetToHTML & strPreceeding & vbCr
    RecordsetToHTML = RecordsetToHTML & "<table border=""1"">" & vbCr
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strSQL, dbReadOnly)
        'first add in headers
        RecordsetToHTML = RecordsetToHTML & "<TR>"
        For Each fld In rs.Fields
            RecordsetToHTML = RecordsetToHTML & "<TD>" & fld.Name & "</TD>"
        Next
        RecordsetToHTML = RecordsetToHTML & "</TR>" & vbCr
        
        'now add in data
        Do Until rs.EOF
            RecordsetToHTML = RecordsetToHTML & "<TR>"
            For Each fld In rs.Fields
                RecordsetToHTML = RecordsetToHTML & "<TD>" & fld.Value & "</TD>"
            Next
            RecordsetToHTML = RecordsetToHTML & "</TR>" & vbCr
            rs.MoveNext
        Loop
        rs.Close
    Set fld = Nothing
    Set rs = Nothing
    Set db = Nothing
    
    RecordsetToHTML = RecordsetToHTML & "</table>" & vbCr
    RecordsetToHTML = RecordsetToHTML & strProceeding & vbCr
    RecordsetToHTML = RecordsetToHTML & "</body>" & vbCr
    RecordsetToHTML = RecordsetToHTML & "</html>"


End Function

pretty impressed with that

RienTimmer · Jun 30, 2008

I have tried this code but get a problem:

If bolAddSignature Or Not IsMissing(varImagePath) Or Not IsMissing(varHtmlFooter) Then 'if signature or embedded image or html footer
Set objInsp = objOutlookMsg.GetInspector 'this causes the default signature to be added to the message
Set objdoc = objInsp.WordEditor
If objdoc Is Nothing Then
strmsg = "Outlook must use Word as the email editor. Follow these instructions to fix the problem." & vbCrLf & vbCrLf & _
"Tools>Options" & vbCrLf & "Then select 'Mail Format' tab" & vbCrLf & "Ensure Use Microsoft Office Word 2003 to edit e-mail messages."
MsgBox strmsg
objOutlookMsg.Close olDiscard
GoTo SendMessage_Done
End If

objdoc ends up being Nothing even though the default editor in Outlook 2003 is Word (and you cannot change it).

Two days later:

I tried this on my home system (also Office 2003) and it works without a hitch...

Forget about it.

ankit_kuchhal · Apr 29, 2009

Hi,
I have some doubt in vbscript.I want to send email to some persons and email's are stored in excel and also data on basis of which email is to be sent. I am able to send text message as email to emails in the excel sheet but i want to insert an image with the text. what would be the possibility to add image in this code???

' Create the Windows and MsOffice session.
Set WshShell = WScript.CreateObject("WScript.Shell")
Set WshNetwork = WScript.CreateObject("WScript.Network")
Set objInputExcel = WScript.CreateObject("Excel.Application")
Set objOutlook = WScript.CreateObject("Outlook.Application")
Set objMailIDsExcel = WScript.CreateObject("Excel.Application")
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")

' Network user Mail id
strUserName = WshNetwork.UserName
' Getting the inputs from the user
strLocation = "C:\Birthday_list.xls"
strMyName = inputbox("Enter your name for the signature","Enter your name",strUserName)
' Checking the Dart/War Status
' Setting the workbook
Set objWorkbook = objInputExcel.Workbooks.Open(strLocation)
'Set objWorkbook = objMailIDsExcel.Workbooks.Open("C:\Automation\MailIDs.csv")

For i = 2 to 66955
if ("20/4" = CStr(Trim(objInputExcel.Cells(i, 3).Value))) Then
' Create the Ms Office session.
Set objWord = CreateObject("Word.Application")
Set myMailItem = objOutlook.CreateItem(olMailItem)

' Getting values from the excel
strName = CStr(objInputExcel.Cells(i, 2).Value)

' Calling the function to get the mail id
MailID = MailIDs(strName)

If (MailID = "") Then
Exit For
End If

' Action

myMailItem.To = MailID
myMailItem.Subject = "BirthDay Wishes for month."
myMailItem.Body = "Dear "& strName & "," & vbCrLf & vbCrLf & vbTab & "Happy BirthDay"& vbCrLf & vbCrLf & vbTab &"Many Many Happy Returns of the day" _
& vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Thanks and regards," & vbCrLf & strMyName
varImagePath = "C:\BirthDay_image.jpeg"
myMailItem.InlineShapes.AddPicture Filename = varImagePath
myMailItem.Display
WScript.Sleep 1000
WshShell.SendKeys "%{k}"
WScript.Sleep 1000
WshShell.SendKeys "%{s}"
myMailItem.Close olSave
objWord.Quit
Else
Exit for
End if
Next

ninosp · Dec 10, 2009

Hi,

First, Nikalopolis congratulations for the excelent code you made!!!

Second, when using it with Office 2007 I had some problems, because if outlook 2007 weren't open the objInsp.WordEditor would always return Nothing.

So I made the following work around

:

Code:

Public Function SendMessage(varTo As Variant, strSubject As String, strBody As String, _
     bolAutoSend As Boolean, bolSaveInOutbox As Boolean, bolAddSignature As Boolean, _
    Optional varCC As Variant, Optional varBCC As Variant, Optional varReplyTo As Variant, Optional varAttachmentPath As Variant, Optional varImagePath As Variant, Optional varHtmlFooter As Variant) As Boolean
'=================================================================
'
'varto: a string of email addresses, multiples delimted by semi-colon
'strSubject: subject line for the email
'strBody: body of the email, must be wrapped in <html> </html> tags, and optionally any other formatting tags
'bolAutoSend: determines whether email is sent automatically or displayed to the user
'bolSaveInOutbox: determines if the message is saved in the outbox
'boladdsignature: determines if the user's default signature is added to the outgoing email
'varCC: (Optional) CC email addresses, multiples delimited by semi-colon
'varBCC: (Optional) BCC email addresses, multiples delimited by semi-colon
'varReplyTo (Optional) If specified sets the reply to email address, multiples delimited by semi-colon
'varAttachmentPath: (Optional) If specified attaches the file
'varImagePath: (Optional) If specified embeds the image in the body of the email
'varHtmlFooter: (Optional) If specifed, inserts an html file as a footer to the message.
'ASSUMPTIONS: Outlook, HTML message format, Word is the default editor
'When performing some of the optional steps the message is constructed in the following order
'signature then embedded image then footer then body text, so the actual email would read as follows
'body text, footer, embedded image, signature
'=================================================================
On Error GoTo HandleError
Dim i As Integer
Dim strtempfile As String
Dim strmsg As String
Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objInbox As Outlook.MAPIFolder
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objInsp As Outlook.Inspector
Dim objword As Word.Application
Dim objdoc As Word.Document
Dim objrange As Word.Range
SendMessage = False
Set objOutlook = New Outlook.Application                                'Create the Outlook session.
objOutlook.Session.Logon
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)                   'Create the message.
Set objNameSpace = objOutlook.GetNamespace("MAPI")                       'Set MAPI Mail
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)               'Set Inbox
objInbox.Display                                                         'Make Outlook visible
strBody = ReplaceCRLFwithBR(strBody)                                    'Replace any vbcrlf with <br>
If (InStr(strBody, "<font") = 0) Or (InStr(strBody, "<html>") = 0) Then                              'if no <html> and <font> tags then wrap the body of the message with these tags
    strBody = FormatAsHtml(strBody)
End If
With objOutlookMsg
 
    If Not IsMissing(varTo) Then
        If varTo <> "" And Not IsNull(varTo) Then
            For i = 1 To CountCSWords(varTo)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varTo, i))               'Add the TO recipient(s) to the message.
                objOutlookRecip.Type = olTo
            Next i
        End If
    End If
    If Not IsMissing(varCC) Then
        If varCC <> "" And Not IsNull(varCC) Then
            For i = 1 To CountCSWords(varCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varCC, i))                  'Add the cc recipient(s) to the message.
                objOutlookRecip.Type = olCC
            Next i
        End If
    End If
 
    If Not IsMissing(varBCC) Then
        If varBCC <> "" And Not IsNull(varBCC) Then
            For i = 1 To CountCSWords(varBCC)
                Set objOutlookRecip = .Recipients.Add(GetCSWord(varBCC, i))                 'Add the bcc recipient(s) to the message.
                objOutlookRecip.Type = olBCC
            Next i
        End If
    End If
 
    If Not IsMissing(varReplyTo) Then
        If varReplyTo <> "" And Not IsNull(varReplyTo) Then
            For i = 1 To CountCSWords(varReplyTo)
                Set objOutlookRecip = .ReplyRecipients.Add(GetCSWord(varReplyTo, i))        'Add the bcc recipient(s) to the message.
            Next i
        End If
    End If
 
 
    If (Not IsMissing(varAttachmentPath)) Then                                                      'if attachment is specified
        If (varAttachmentPath <> "") And (Not IsNull(varAttachmentPath)) Then                       'check it is valid
            If Dir(varAttachmentPath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then    'check the file actually exists
                Set objOutlookAttach = .Attachments.Add(CStr(varAttachmentPath))                      'Add attachments to the message.
            End If
        End If
    End If
 
 
    .Subject = strSubject               'Set the Subject of the message.
    .BodyFormat = olFormatHTML          'set format to html
 
    If bolAddSignature Or Not IsMissing(varImagePath) Or Not IsMissing(varHtmlFooter) Then  'if signature or embedded image or html footer
        Set objInsp = objOutlookMsg.GetInspector                                            'this causes the default signature to be added to the message
        Set objdoc = objInsp.WordEditor
        If objdoc Is Nothing Then
            strmsg = "Outlook must use Word as the email editor. Follow these instructions to fix the problem." & vbCrLf & vbCrLf & _
                "Tools>Options" & vbCrLf & "Then select 'Mail Format' tab" & vbCrLf & "Ensure Use Microsoft Office Word 2003 to edit e-mail messages."
            MsgBox strmsg
            objOutlookMsg.Close olDiscard
            GoTo SendMessage_Done
        End If
 
        Set objword = objdoc.Application
 
        If bolAddSignature = False Then         'If the user had a signature it would have been applied, if we dont want it then we need to delete it here
            objdoc.Range.Delete
        End If
 
        If Not IsMissing(varImagePath) Then
            If varImagePath <> "" And Not IsNull(varImagePath) Then
                If Dir(varImagePath, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    On Error Resume Next
                    .Display                                                                        'Seems like word document must be visible before you can use addpicture method
                    If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
                        MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
                        .Close olDiscard
                        GoTo SendMessage_Done
                    End If
                    objword.WindowState = wdWindowStateMinimize                                     'minimize word application so user does not see mail being created
                    Set objrange = objdoc.Range(Start:=0, End:=0)                                   'goto start of message again
                    objrange.InsertBefore vbCrLf
                    objdoc.InlineShapes.AddPicture Filename:=varImagePath, LinkToFile:=False, SaveWithDocument:=True, Range:=objrange
                End If
            End If
        End If
        If Not IsMissing(varHtmlFooter) Then
            If varHtmlFooter <> "" And Not IsNull(varHtmlFooter) Then
                If Dir(varHtmlFooter, vbHidden + vbSystem + vbReadOnly + vbDirectory) <> "" Then
                    Set objrange = objdoc.Range(Start:=0, End:=0)                                   'goto start of message
                    objrange.InsertFile varHtmlFooter, , , False, False   'insert the html from the external file
                End If
            End If
        End If
 
        strtempfile = Environ("temp") & Format(Now(), "yyyymmddhhnnss") & ".htm"        'generate temp filename
        Set objrange = objdoc.Range(Start:=0, End:=0)                                   'goto start of message again
        CreateTextFile strtempfile, strBody                                             'save the bodytext as a temporary htm file
        objrange.InsertFile strtempfile, , , False, False                               'insert the htm file into the body of the message
        Kill strtempfile                                                                'delete temp file
 
        objdoc.SpellingChecked = True                                                   'doesnt matter for autosend, but helps the user if the message is being displayed
    Else
        .HTMLBody = strBody
    End If
 
    If bolSaveInOutbox = False Then             'if message not to be saved after sending
        .DeleteAfterSubmit = True               'specify that it should be deleted
    End If
 
    If (bolAutoSend = True) And (.Recipients.Count > 0) Then        'check that there is at least 1 recipient before trying to autosend
        .Send
    Else
        Err = 0
        On Error Resume Next
        .Display                    'Attempt to display the message
        If Err <> 0 Then            'if the mail cound not be displayed then display a warning and discard the message
            MsgBox "It was not possible to display the message, check that there are no dialog boxes open in Outlook." & vbCrLf & "Please close all Outlook windows and emails, and then attempt this update again.", vbCritical
            .Close olDiscard
            GoTo SendMessage_Done
        End If
    End If
End With
 
SendMessage = True
SendMessage_Done:
    Set objOutlook = Nothing
    Set objNameSpace = Nothing
    Set objInbox = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set objInsp = Nothing
    Set objword = Nothing
    Set objdoc = Nothing
    Set objrange = Nothing
    Exit Function
HandleError:
    MsgBox Err.Number & ":" & Err.Description, vbCritical
    Resume SendMessage_Done
End Function
Public Function ReplaceCRLFwithBR(ByVal strText) As String
'=================================================================
'Replace all vbcrlf with <br> to keep line breaks in html emails
'=================================================================
strText = Replace(strText, Chr(13), "<br>")
strText = Replace(strText, Chr(10), "")
ReplaceCRLFwithBR = strText
 
End Function
Public Function FormatAsHtml(ByVal str) As String
'=================================================================
'Wraps a string in html tags
'=================================================================
FormatAsHtml = "<html><font face=""arial"" size=""2"">" & str & "</font></html>"
End Function
Public Function GetCSWord(ByVal str, Indx As Integer, Optional strdelimiter = ";") As String
'=================================================================
'Returns the nth word in a specific field
'=================================================================
On Error Resume Next
GetCSWord = Split(str, strdelimiter)(Indx - 1)
End Function
Function CountCSWords(ByVal str, Optional strdelimiter = ";") As Integer
'=================================================================
'Counts the words in the delimited string
'=================================================================
Dim WC As Integer, Pos As Integer
If VarType(str) <> 8 Or Len(str) = 0 Then
    CountCSWords = 0
    Exit Function
End If
WC = 1
Pos = InStr(str, strdelimiter)
Do While Pos > 0
    WC = WC + 1
    Pos = InStr(Pos + 1, str, strdelimiter)
Loop
CountCSWords = WC
 
End Function
 
Public Sub CreateTextFile(strFullPath As String, strText As String)
'=================================================================
'Creates a text file with the specified file name containing the supplied text
'=================================================================
Dim fso As Object
Dim MyFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(strFullPath, True)          'Creates file, existing file will be overwritten
MyFile.WriteLine (strText)                                  'writes string to the file
MyFile.Close                                                'close the file
 
End Sub
Public Function GetTextFile(ByVal strFile As String) As String
'=================================================================
'Returns a string that contains the contents of the specified file
'=================================================================
 
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(strFile).OpenAsTextStream(1, -2)       'Open the file ForReading, Use system default for file format
GetTextFile = ts.readall                                    'Read the contents of the file
ts.Close                                                    'Close the file
 
End Function

The piece of coded I added make the Outlook visible (Another workaround

since outlook doesn’t have a visible propriety) before creating the message, so now the objInsp.WordEditor is working properly.

I also added an example file.

Bye.

nadav · Jan 5, 2010

Hi,

Thanks so much for this code. I'm planning on using it in my youth movement's database. I assume that it's free to use given that it's been posted publicly here?

I didn't manage to get the WordEditor working with Outlook 2007. Supposedly I need to use Inspector.Activate() or something first, but I'm not sure how.

Anyway, I don't think I need that part of the code (the signature, footer etc.), so I've just deleted it and it works perfectly!

Thanks very much again
Nadav

wllsth · Jun 16, 2010

I have just inserted the above code in a routine on my DB and it works fine. The only issue I have is that it creates a new session of Outlook when there is already one running. I wish the messages to be viewed and edited prior to sending so I dont want to autosend them. Do you have a work around ?? I'm using Access 2007 and Outlook 2007

tracknut · Oct 18, 2010

an excellent bit of code....thanks

JustWhatINeeded · Jan 14, 2012

Okay, have tried this in OL 2010 and when manually (f8) walking this through it gets to the decision to Send or Display - if I make it go though the .Display step it works, but if i make it go through the .Send i dont get any 'body' in the email. Any suggestions please?

wllsth · Jan 15, 2012

Just tested the following code using Access 2010 and Outlook 2010 and seems to workk fine - Good luck

Private Sub Command223_Click()
RunCommand acCmdSaveRecord
DoCmd.OpenReport "EstimatePrint", acViewReport, , "[EstimateID]=" & [ID]
DoCmd.OutputTo acOutputReport, "EstimatePrint", acFormatPDF, "C:\Users\Tom\Quotation.pdf"
On Error GoTo Err_SendEmail

Dim sTo As String
Dim sCC As String
Dim sSubject As String
Dim sBody As String
Dim sAttachmentList As String
Dim sReplyRecipient As String
Dim sPathFile As String
sPathFile = "C:\Users\Tom\Quotation.pdf"

'You must key a semicolon between each email name.
sTo = [Contact e-Mail]
sCC = ""
sReplyRecipient = " "
sSubject = [Site Address] & " - Quotation"

sAttachmentList = sPathFile

' sBody = " "

'send email with a file attachment
Call SetupOutlookEmail(sTo, sCC, sReplyRecipient, sSubject, sBody, sAttachmentList)

'send email without a file attachment
'Call SetupOutlookEmail(sTo, sCC, sReplyRecipient, sSubject, sBody)

Exit_SendEmail:
Exit Sub

Err_SendEmail:
If Err.Number = -2147024894 Then 'Cannot find this file. Verify the path and file name are correct.
MsgBox "Email message was not sent. Please verify the file exists @ " & sPathFile & " before attempting to resend the email.", vbCritical, "Invalid File Attachment"
Exit Sub
ElseIf Err.Number = -2147467259 Then 'Outlook does not recognize one or more names.
MsgBox "Email message was not sent. Please verify all user names and email addresses are valid before attempting to resend the email.", vbCritical, "Invalid Email Name"
Exit Sub
Else
MsgBox Err.Number & " - " & Err.Description, vbCritical, "SendEmail()"
Resume Exit_SendEmail
End If

End Sub

Public Function SetupOutlookEmail(ByVal sTo As String, ByVal sCC As String, ByVal sReplyRecipient As String, ByVal sSubject As String, ByVal sBody As String, ParamArray sAttachmentList() As Variant) As Boolean
On Error GoTo Err_SetupOutlookEmail

Dim objOLApp As Object
Dim outItem As Object
Dim outFolder As Object
Dim DestFolder As Object
Dim outNameSpace As Object
Dim lngAttachment As Long
Dim SigString As String
Dim Signature As String

Set objOLApp = CreateObject("Outlook.Application")
Set outNameSpace = objOLApp.GetNamespace("MAPI")
Set outFolder = outNameSpace.GetDefaultFolder(6)
Set outItem = objOLApp.CreateItem(0)

sBody = "<HTML><BODY>Thank you for your recent enquiry. " & _
"Please find attached our quotation, if you have any queries then please do not hesitate to contact us. " & _
" Thanking you in anticipation<BODY><HTML>"

SigString = "C:\Users\Tom\Appdata\Roaming\Microsoft\Signatures\TomRFC.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

outItem.To = sTo
outItem.CC = sCC
outItem.Subject = sSubject
outItem.HTMLBody = sBody & " " & Signature
outItem.ReplyRecipients.Add sReplyRecipient
outItem.ReadReceiptRequested = False

With outItem.Attachments
For lngAttachment = LBound(sAttachmentList) To UBound(sAttachmentList)
.Add sAttachmentList(lngAttachment)
Next lngAttachment
End With

'outItem.Send
outItem.Display 'setup and open email in edit mode instead of sending the email
SetupOutlookEmail = True

Exit_SetupOutlookEmail:
On Error Resume Next
Set outItem = Nothing
Set outFolder = Nothing
Set outNameSpace = Nothing
Set objOLApp = Nothing
Exit Function

Err_SetupOutlookEmail:
If Err.Number = 287 Then 'User stopped Outlook from sending email.
MsgBox "User aborted email.", vbInformation, "Email Cancelled"
Resume Exit_SetupOutlookEmail
Else
MsgBox Err.Number & " - " & Err.Description, vbCritical, "SetupOutlookEmail()"
Resume Exit_SetupOutlookEmail
End If

End Function

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

leahcorp · Mar 3, 2015

I was wondering if it is possible to add SentOnBehalfOfName to nikalopolis's code above so that I can set the "From" field with a specific email address. Thank you!

hardyd44 · Mar 19, 2015

hi,

I want use this code (thanks for posting it) as I have several functions that send emails with attachments and this would allow me to clean up the code by using 1 function, but....

I need to add a category for some emails at the point of sending and I cant suss out where I would insert that

can anyone help?

hardyd44 · Mar 20, 2015

Sussed it,

if anyone wants me to post the full code - just let me know

Dean

hardyd44 · Mar 24, 2015

Now hit another problem,

I need to multiple attachments, previously I have used a loop and used .attachments.add to do this, however using this method I only get the last attachment.

I know I need to create an array but I am stuck on how to achieve this - can anyone help

Thanks

Dean

hardyd44 · Jun 30, 2015

BUMP

been on other projects for a while, but now back to this :banghead:

still stuck with attaching more than one attachment - can anyone help

Thanks

Gasman · Jul 2, 2015

I've just approached this very same problem and have managed to do it this way for now.

Put all the required files in a folder and use Dir to get the filenames.

The code will add each attachment.

Otherwise obtain all the full path names of the files and add them in some sort of loop.

FWIW here is my code (mainly copied from the net and amended to suit).

Code:

Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim strSigPath As String, strSignature As String, strAttachFile As String
          
    'Get the signature
    strSigPath = Environ("Appdata") & "\Microsoft\Signatures\Ssafa.htm"
    If Dir(strSigPath) <> "" Then
        strSignature = GetBoiler(strSigPath)
    End If

    ' Create the Outlook session.
    Set objOutlook = GetObject(, "Outlook.Application")

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

    With objOutlookMsg
        ' Add the To recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("Jim  - SSAFA Swansea")
        objOutlookRecip.Type = olTo

        ' Add the CC recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("** SSAFA West Glamorgan Branch")
        objOutlookRecip.Type = olCC

        ' Add the BCC recipient(s) to the message.
        'Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
        'objOutlookRecip.Type = olBCC

        ' Set the Subject, Body, and Importance of the message.
        .SentOnBehalfOfName = "Paul Steel [dt@gmail.com]"
        .Subject = "This is an Automation test with Microsoft Outlook"
        .HTMLBody = "This is the body of the message." & vbCrLf & vbCrLf & strSignature
        .Importance = olImportanceHigh  'High importance

        ' Add attachments to the message. These will all be in one folder
        If Not IsMissing(AttachmentPath) Then
            strAttachFile = Dir(AttachmentPath & "*.*")
            Do While Len(strAttachFile) > 0
                Set objOutlookAttach = .Attachments.Add(AttachmentPath & strAttachFile)
                strAttachFile = Dir
            Loop
        End If

        ' Resolve each Recipient's name.
        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
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
End Sub

HTH

hardyd44 · Jul 3, 2015

Gasman,

cheers - we give it a try and let you know

Dean

hardyd44 · Feb 16, 2016

Gasman,

did not work for me the way I wanted, left it alone while I pursued other projects,

Now finally have it working using a complete set of new code found elsewhere and adopted

Code:

Dim oOutlook As outlook.Application
Dim oemailitem As MailItem
Dim myAttachments As outlook.Attachments

Set oOutlook = GetObject(, "outlook.application")
If oOutlook Is Nothing Then
Set oOutlook = New outlook.Application
End If

Set oemailitem = oOutlook.CreateItem(olMailItem)
With oemailitem
Set fso = New FileSystemObject

.Display
End With
'# assign system signature to HTMLbody
signature = oemailitem.HTMLBody
With oemailitem

.To = "test@test.Controls.uk"
.subject = "test subject"
'# adding body text and system signature
'& "<B>" & Me.JobDetails & "</B>"
.HTMLBody = "<HTML><BODY>" & "<B>" & "Hello" & "</B><BR><Br>" & "add body text here" & vbNewLine & "</BODY></HTML>" & signature
' loop to add more than one invoice
    Me.currentattachvalue.Value = Me.FirstInvNo.Value
    Do While Me.SecondInvNo.Value > Me.currentattachvalue.Value - 1

  
  fileattachment$ = "\\Loftsvr\documents\PDFInvoiceCopies\UtilityOils\U" & Me.currentattachvalue.Value & ".pdf"
    
     Me.currentattachvalue.Value = Me.currentattachvalue.Value + 1



   
            '
            'Now check that the file exists - if the file has been output, it will be!!
            '
            If fso.FileExists(fileattachment$) = False Then
            '
           MsgBox "The Attachment file is not where you say it is. " & vbNewLine & vbNewLine & _
            "Quitting...", vbCritical, "Incorrect file path"
           Exit Sub
          End If
            '
Set myAttachments = oemailitem.Attachments
            myAttachments.Add fileattachment$, olByValue, 1, "Invoices"
          

         Loop
 
 
End With
Set oemailitem = Nothing
Set oOutlook = Nothing

This works for me and adds the attachments one by one, a lot simpler code, it is still a bit rough round the edges but it works, hope this helps anyone stuck with the same problem

Send html Outlook Email, options for signature, attach, embed image plus many more

New member

New member

Registered User.

Registered User.

New member

New member

New member

Attachments

New member

Registered User.

New member

New member

Registered User.

Registered User.

Registered User.

Registered User.

Registered User.

Registered User.

Enthusiastic Amateur

Registered User.

Registered User.

Similar threads

Users who are viewing this thread