Sending Outlook mail using Excel VBA

Anonymous
Jun 07, 2018
OK, here is the solution that is working. The critical change was to construct the text for the email, including calling the RangeToHtml function, before going to Outlook.

Code prior to this point selects and copies the desired content on the source worksheet.

'Formatted text to go in email before table from Excel
strbody1 = " Text before table "

'Text to go in email after table
strbody2 = " Text after table "

Table = RangetoHTML(MyHTMLRng)

 Dim OutApp As Object
Dim OutMail As Object
Dim OutlookOpened As Boolean
 OutlookOpened = False
 On Error Resume Next
 Set OutApp = GetObject(, "Outlook.Application")
 If OutApp Is Nothing Then
 Set OutApp = CreateObject("Outlook.Application")
 OutlookOpened = True
 End If

 Set OutMail = OutApp.CreateItem(0)
 On Error Resume Next
 With OutMail
 .Display
 .Subject = "My Subject"
 Signature = OutMail.HTMLBody
 .HTMLBody = strbody1 & Table & strbody2 & Signature
 End With
 On Error GoTo 0
 Set OutMail = Nothing
 Set OutApp = Nothing

Application.ScreenUpdating = True
End Sub

Function RangetoHTML(MyHTMLRng)
 Dim fso As Object
 Dim ts As Object
 Dim TempFile As String
 Dim TempWB, wbName, wbThis As Workbook
 Dim rngNew As Range
 Dim x As Integer
 TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 'Create a new workbook to paste the source table data into
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
' This next bit deletes a blank row in the table if one is found. There cannot be more than one, so the loop exits if one is found.
 For myRow = 1 To 100
 If Len(.Cells(myRow, 1).Value) < 1 Then
 .Cells(myRow, 1).EntireRow.Delete
 Exit For
 End If
 Next
 Application.CutCopyMode = False
 On Error Resume Next
 .DrawingObjects.Visible = True
 .DrawingObjects.Delete
 On Error GoTo 0
 End With
 'Publish the sheet to a htm file
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (False) 'True will replace, rather than insert
 End With
 'Read all data from the htm file into RangetoHTML
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.ReadAll
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
 "align=left x:publishsource=")
 'Close TempWB
 TempWB.Close savechanges:=False
 'Delete the htm file we used in this function
 Kill TempFile
 Set ts = Nothing
 Set fso = Nothing
 Set TempWB = Nothing
End Function
Anonymous
Jun 05, 2018
We've come up with a solution that's working! It's not much different than what is above but different enough I guess, because it's working. I'll post the details after a bit more testing but I wanted to let you know that we can all "stand down" for now.
Anonymous
Jun 01, 2018
Code prior to this selects and copies the relevant range in Excel

Dim OutApp As Object
 Dim OutMail As Object
 Dim OutlookOpened As Boolean
 OutlookOpened = False
 On Error Resume Next
 Set OutApp = GetObject(, "Outlook.Application")
 If OutApp Is Nothing Then
 Set OutApp = CreateObject("Outlook.Application")
 OutlookOpened = True
 End If

'Create a dummy email and close it without saving
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Test"
.Close 1
End With

'Text before table
strbody1 = "<BODY style=font-size:10pt;font-family:Arial; margin-bottom: 0em> Some leading text</BODY>"

'Text after table
strbody2 = "<BODY style=font-size:10pt;font-family:Arial; margin-bottom: 0em > Some trailing text </BODY>"

 Set OutMail = OutApp.CreateItem(0)
 On Error Resume Next
 With OutMail
 .Display
 Signature = OutMail.HTMLBody
 .Subject = "My eMail"
 .HTMLBody = strbody1 & RangetoHTML(MyHTMLRng) & strbody2 & Signature
 End With
 On Error GoTo 0
 Set OutMail = Nothing

 If OutlookOpened Then OutApp.Quit
 Set OutApp = Nothing

End Sub

Function RangetoHTML(MyHTMLRng)
 Dim fso As Object
 Dim ts As Object
 Dim TempFile As String
 Dim TempWB As Workbook
 TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 'Copy the range and create a new workbook to past the data in
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 On Error Resume Next
 .DrawingObjects.Visible = True
 .DrawingObjects.Delete
 On Error GoTo 0
 End With
 'Publish the sheet to a htm file
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (False) 'False will insert, rather than replace
 End With
 'Read all data from the htm file into RangetoHTML
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.ReadAll
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
 "align=left x:publishsource=")
 'Close TempWB
 TempWB.Close savechanges:=False
 'Delete the htm file we used in this function
 Kill TempFile
 Set ts = Nothing
 Set fso = Nothing
 Set TempWB = Nothing
End Function
Matt Mickle
Bronze Contributor
Jun 01, 2018
Wayne-

Can you please send me your updated VBA code with the RangeToHTML portion incorporated? Specifically the email portion of the code. I believe your issue revolves around the method the code is incorporating the email signature portion (Either way it would be helpful to use the code when testing).

Forum Discussion

Resources