Losing Table theme in RangetoHTML VBA

[dotsent]

Hi! I'm using the popular VBA code for range-to-Email functionality.

My emailed range includes table with header + a few extra rows below, all belonging to "MyRange". I want to improve the visuals of the emailed range and enabled "Banded rows" under "Table Design". I also considered a different theme with just borders between rows, but I end up with the same problem - when VBA code is launched, all "Table Design" theme formatting is lost in Outlook message.

It took me some time to understand why, as only manually added formatting stays (as seen on screenshot). To be fair, copy-pasting this range manually within Excel works the same, e.g. loses this formatting (although interestingly enough, manual copy-paste straight to Outlook message will retain everything).

Apparently this is caused by "MyRange" not including JUST the table, but also extra rows beneath it ("Period amount"; "Total amount"). Limiting "MyRange" to just the table retains full Table Design theme formatting in Outlook message.

Enabling table's "Total row" and adding "Period amount" and "Total amount" there would technically work, however I'd like to print them on top of each other. AFAIK "Total Row" would only allow them to be printed side by side. I'd also like to have a little bit of empty space between rows and totals - hence positioning outside of table looked to tick all the boxes.

I could also use a mail body text for displaying this extra data, but I see it being more difficult to position this aesthetically.

And to phrase the question: do you guys see a way I could still use a MyRange bigger than the actual table, but still retain the Table Design theme? Or should I look for a different path? Thanks for any ideas!

Sub Email()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
      
    Set rng = Nothing
    On Error Resume Next

    Set rng = Sheets("Sheet1").Range("MyRange").SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "test@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "MySubject"
        .Htmlbody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
       
End Sub

Function RangetoHTML(rng As Range)

    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"

    rng.Copy
    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

    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

    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=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
      
End Function

 

[John_w]

Try changing:

        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False

to simply:

        .Paste

 

[dotsent]

Try changing:

        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False

to simply:

        .Paste

Thanks for the suggestion, John. Unfortunately that didn't help. Manual copy-paste of this range within Excel loses the same formatting attributes too, so I can see why plain VBA Paste would not work. I feel like the range itself is causing the issue here.