Losing Table theme in RangetoHTML VBA

dotsent

Board Regular
Joined
Feb 28, 2016
Messages
60
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!





Code:
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,999
Try changing:
Code:
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
to simply:
Code:
        .Paste
 

dotsent

Board Regular
Joined
Feb 28, 2016
Messages
60
Try changing:
Code:
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
to simply:
Code:
        .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.
 
Last edited:

Forum statistics

Threads
1,082,257
Messages
5,364,074
Members
400,778
Latest member
Canadian Sal

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top