Losing Table theme in RangetoHTML VBA

dotsent

Board Regular
Joined
Feb 28, 2016
Messages
85
Office Version
  1. 365
Platform
  1. Windows
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!


outlookattach.jpg



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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Try changing:
Code:
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
to simply:
Code:
        .Paste
 
Upvote 0
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:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,205
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top