RangetoHTML function changes formatting of everything after it

Hello all, I am on Excel 2010 VBA. I am using the Ron De Bruin RangetoHTML function to copy and paste sections of a spreadsheet to different email addresses, using an email template that I have created with placeholder text for where the RangetoHTML contents should go. I only needed the RangetoHTML for a certain section of the email body since the rest of the email will be the same for everyone else.

Everything seems to work fine but instead of the replace function just replacing the placeholder text with the range that is copied from the spreadsheet, everything below the range in the email text is now formatted differently even though everything before the pasted range looks correct. Does anyone know how this could be fixed, if at all? The entire code I used is below.

Option Explicit
Sub Emails()
Dim i As Long
Dim OutlookApp As Object
Dim OutlookItem As Object
Const OutlookMailItem As Long = 0
Dim intChoice As Integer
Dim 1TemplatePathAnswer As Integer
Dim 1TemplatePath As String
Dim 2TemplatePathAnswer As Integer
Dim 2TemplatePath As String
Dim 2Contact As String
Dim rng As Range

1TemplatePathAnswer = MsgBox("Do you know the path for the #1 email template?", vbYesNoCancel + vbQuestion, _
           "Please Respond")
If 1TemplatePathAnswer = vbYes Then
    'Get filepath for the RFI
    With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = "C:\Users\" & Environ$("Username") & "\AppData\Roaming\Microsoft\Templates"
    .AllowMultiSelect = False
    'make the file dialog visible to the user
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    'determine what choice the user made
    If intChoice <> 0 Then
    'get the file path selected by the user
      1TemplatePath = Application.FileDialog( _
            msoFileDialogOpen).SelectedItems(1)
        Else: End
    End If
    End With
ElseIf 1TemplatePathAnswer = vbCancel Then
        Exit Sub
ElseIf 1TemplatePathAnswer = vbNo Then
        MsgBox ("You will need to know the location of the email template to use this macro.")
        Exit Sub
End If

2TemplatePathAnswer = MsgBox("Do you know the path for the #2 email template?", vbYesNoCancel + vbQuestion, _
           "Please Respond")
If 2TemplatePathAnswer = vbYes Then
    'Get filepath for the RFI
    With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = "C:\Users\" & Environ$("Username") & "\AppData\Roaming\Microsoft\Templates"
    .AllowMultiSelect = False
    'make the file dialog visible to the user
    intChoice = Application.FileDialog(msoFileDialogOpen).Show
    'determine what choice the user made
    If intChoice <> 0 Then
    'get the file path selected by the user
      2TemplatePath = Application.FileDialog( _
            msoFileDialogOpen).SelectedItems(1)
        Else: End
    End If
    End With
ElseIf 2TemplatePathAnswer = vbCancel Then
        Exit Sub
ElseIf 2TemplatePathAnswer = vbNo Then
        MsgBox ("You will need to know the location of the email template to use this macro.")
        Exit Sub
End If

'Step 1: Initialize an Outlook session.
Set OutlookApp = CreateObject("Outlook.Application")
'Step 2: For each non-empty cell in the range, create a new message.
Range("A2").Select
Do Until IsEmpty(ActiveCell)
2Contact = ActiveCell.Offset(0, 7).Value
    Do Until ActiveCell.Offset(0, 7).Value <> 2Contact
    Set OutlookItem = OutlookApp.CreateItemFromTemplate(1TemplatePath)
    On Error Resume Next
    With OutlookItem
    'Step3: Add the To recipient(s) to message.
        .To = ActiveCell.Offset(0, 2).Value
        .HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER1%", ActiveCell.Offset(0, 5).Value)
        .HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER2%", ActiveCell.Offset(0, 6).Value)
        .HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER3%", ActiveCell.Offset(0, 7).Value)
        .Importance = olImportanceHigh 'High importance
        .Display
    End With
    On Error GoTo 0
    i = i + 1
    ActiveCell.Offset(1, 0).Select
    Loop
Set rng = Range(ActiveCell.Offset(-i, 0), ActiveCell.Offset(0, 2))
Set OutlookItem = OutlookApp.CreateItemFromTemplate(2TemplatePath)
With OutlookItem
'Step3: Add the To recipient(s) to message.
    .To = 2Contact
    .HTMLBody = Replace(.HTMLBody, "RANGETOHTML PLACEHOLDER", RangetoHTML(rng))
    .HTMLBody = Replace(.HTMLBody, "PLACEHOLDER1", ActiveCell.Offset(0, 5))
    .Importance = olImportanceHigh 'High importance
    .Display
    End With
i = 0
2Contact = ActiveCell.Offset(0, 7).Value
Loop
Set OutlookApp = Nothing
Set OutlookItem = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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)
    rng.Copy
    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 (True)
    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

Originally Posted by Bernie Deitrick

What happens if you do the insertion of the HTML range last? Switching the order of these two line to this:

    .HTMLBody = Replace(.HTMLBody, "PLACEHOLDER1", ActiveCell.Offset(0, 5))
    .HTMLBody = Replace(.HTMLBody, "RANGETOHTML PLACEHOLDER", RangetoHTML(rng))

It does appear to make the same mistake. Also, I think I should have mentioned that the code seems to keep the color and size of the text, but changes the font to Times New Roman which is not what it should be. And also I said everything after the RangetoHTML changed font but I meant everything after it but before the signature (which does still have the correct formatting for some reason).

Originally Posted by Norie

How do you want the body of the email after the HTML section to be formatted?

Does it make any difference if you add opening and closing HTML body tags either side of RangetoHTML(rng) here?

 .HTMLBody = Replace(.HTMLBody, "RANGETOHTML PLACEHOLDER", RangetoHTML(rng))

Note, I tried posting the tags I mentioned but apparently I broke some sort of security protocol or something in trying to do so.

Anyway, here is a link.

The text after the RangetoHTML and before the signaturshould be Calibri font, size 11, and RGB 31,73,125. So you mean use the literal tags that have the letters html inside or some other combination of html tags (like body or something else)? By the way I am writing it out in words to avoid the same error you mentioned by including HTML tags.