Copying Excel table with gradient filled cells to Outlook mail - excel

Question

I have a table in Excel that I want to send to a distribution list in Outlook with the table in the email body.
Using MVP Ron de Bruin's examples and a few others on here I've got code that keeps some of the table formatting but doesn't copy the cells colour if it is a gradient (please use the images as reference).
Sub DisplayEmailButton_Click()
Mail_Selection_Range_Outlook_Body
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Sheet1").Range("C2:Q18").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
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 = "Team01"
.CC = ""
.BCC = ""
.Subject = "Daily Statistics"
.HTMLBody = "Please see attached daily statistics." & vbCrLf &
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 TempFile As String, ddo As Long
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Temporary publish the rng range to a htm file
ddo = ActiveWorkbook.DisplayDrawingObjects
ActiveWorkbook.DisplayDrawingObjects = xlHide
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=Union(rng, rng).Address, _
HtmlType:=xlHtmlStatic)
.Publish True
.Delete
End With
ActiveWorkbook.DisplayDrawingObjects = ddo
'Read all data from the htm file into RangetoHTML
With
CreateObject("Scripting.FileSystemObject").GetFile(TempFile)
.OpenAsTextStream(1, -2)
RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left
x:publishsource=")
.Close
End With
'Delete the htm file we used in this function
Kill TempFile
End Function

Answer 1

As Tim suggested I was expecting way too much from that procedure (Thank you, Tim, for the advice!) so I looked into a workaround. If the range is saved as a picture then it keeps all the formatting and the picture can then easily be attached to an email or displayed in the body of the email.
To save as a picture:
Dim Wb As ThisWorkbook
Dim Ws As Worksheet
Dim Ch As Chart
Set Rng = Ws.Range("A1:G18")
Set Ch = Charts.Add
Ch.Location xlLocationAsObject, "Sheet2"
Set Ch = ActiveChart
ActiveChart.Parent.Name = "StatsTemp"
ActiveSheet.ChartObjects("StatsTemp").Height = Rng.Height
ActiveSheet.ChartObjects("StatsTemp").Width = Rng.Width
Rng.CopyPicture xlScreen, xlBitmap
Ch.Paste
Ch.Export Environ("UserProfile") & "\Desktop" & "\" & Format("TempImage") & ".jpg"
Worksheets("Sheet2").ChartObjects("StatsTemp").Delete
Worksheets("Sheet1").Activate
The above code saves the range as an image "TempImage.JPG" to the users desktop by creating a new chart on sheet 2, pasting the range to the chart then saves the chart as an image and deletes the chart.
To attach the picture to an email in the email body:
Dim StrBody As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
StrBody = "Some text here." & "<br>"
On Error Resume Next
With OutMail
.to = "email address"
.CC = ""
.BCC = ""
.Subject = "Email Subject"
.HTMLBody = StrBody & "<img src = '" & Environ("userProfile") &
"\desktop\TempImage.jpg'>"
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
The above code creates an email using Microsoft Outlook which contains the saved image file in the email body and displays the email.
The image can be deleted after using:
Kill Environ("UserProfile") & "\Desktop" & "\TempImage.jpg"
Hopefully, this will be of some use to someone!
Credit to Ron de Bruin Microsoft Office MVP for his WinTips!