Sending Outlook mail using Excel VBA

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 = "<span style=font-size:10pt;font-family:Arial; margin-bottom: 0px> Text before table </span>"

'Text to go in email after table

strbody2 = "<span style=font-size:10pt;font-family:Arial; margin-bottom: 0em <br/> Text after table </span>"

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

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.

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 > <p> 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