Excel selected range to Outlook email body - Formatting problem

Question

I spent few hours looking for help on the forum. But my level of VBA is not on such level that I would be able to implement and test the changes in code.

In short, I have an excel file and I want to send Range selected via outlook email. Many tutorials here and this is working fine.

But my trouble is the formatting. No matter how I try the row height in the outlook email keeps messing up and graphs are overlapping the tables etc. The rows width and object positions are ok though.

So is there any trick, how to keep the formatting exactly the same as in the excel file?

Here is the code for sending the range via email which is working:

Private Sub Workbook_Open()

ActiveWorkbook.RefreshAll

'Working in Excel 2002-2016
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range

Sheets("Data").Select

On Error GoTo StopMacro

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

'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Data").Range("A1:S600")

'Remember the activesheet
Set AWorksheet = ActiveSheet

With Sendrng

    'Select the worksheet with the range you want to send
    .Parent.Select

    'Remember the ActiveCell on that worksheet
     Set rng = ActiveCell

    'Select the range you want to mail
    .Select

    ' Create the mail and send it
      ActiveWorkbook.EnvelopeVisible = True
      With .Parent.MailEnvelope

        ' Set the optional introduction field thats adds
        ' some header text to the email body.
        '.Introduction = "Hello all."

        With .Item
             .To = "xxx@zzz.eu"
             .CC = "xxx@zzz.eu"
             .BCC = ""
             .Subject = "xxx" & Format(Worksheets("Support").Range("A1").Value, "dd.mm.yyyy")
             .Send
        End With

    End With

    'select the original ActiveCell
    rng.Select
End With

'Activate the sheet that was active before you run the macro
AWorksheet.Select

StopMacro:
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False

ActiveWorkbook.Save
Application.Quit

End Sub

Answer 1

You could refer to the below code:

Function RangetoHTMLFlexWidth(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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
    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

    '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)
    RangetoHTMLFlexWidth = ts.readall
    ts.Close
    RangetoHTMLFlexWidth = Replace(RangetoHTMLFlexWidth, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    Dim startIndex As Long
    Dim stopIndex As Long
    Dim subString As String

    'Change table width to "100%"
    startIndex = InStr(RangetoHTMLFlexWidth, "<table")
    startIndex = InStr(startIndex, RangetoHTMLFlexWidth, "width:") + 5
    stopIndex = InStr(startIndex, RangetoHTMLFlexWidth, "'>")
    subString = Left(RangetoHTMLFlexWidth, startIndex)
    subString = subString & "100%"
    RangetoHTMLFlexWidth = subString & Mid(RangetoHTMLFlexWidth, stopIndex)

    '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

For more information, please refer to the below link:

Send Excel range into Email body with autofit