Issue VBA Copying/Displaying Table in Email Body

Hi everyone,

I have a very limited VBA knowledge and have been struggling with the following;

Everyday I'm sending different data by email and found a way thanks to VBA to automate the process, when I get to the "creation email step", I have some issues apparently because of the format (not in HTML), displaying the email addresses and text in the body is fine as it is all linked to specific cells however if I want to display a table (within a specific range) it does not work

My current code is the following;

Sub George()
Dim a As Integer
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

a = ActiveCell.Row

With ActiveSheet
Set rngTo = .Cells(22, "B")
Set rngCc = .Cells(24, "B")
Set rngSubject = .Cells(26, "B")
Set rngBody = .Range("B28")
'Set rngAttach = .Range("B4")
End With

With objMail
.To = rngTo.Value
.CC = rngCc.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
'.Attachments.Add rngAttach.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
To recap my query is: "how to display a specific range as an email body from excel ?"

Apologies if I'm in the wrong section of the forum or if it has already been discussed, I tried to solve this by visiting other places and reading people with the same issue but couldn't solve it

Thank you very much
Regards

DidierIV

.

Code:

---

Option Explicit


Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
    ws1.Range("A1:M42").Copy '<---------------------------------------------adjust range here
    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
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").Range("A1:M42") '<---------------------------------------------adjust range here
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Your Subject Here"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
   
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .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"
    '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)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    '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

---

You can access the body of the message directly as if it was a Word document (which as Outlook uses elements of Word as editor, it effectively is) thus to insert a selection of the workbook -

Code:

---

Option Explicit

Sub SendWorkBook()
'Graham Mayor - http://www.gmayor.com - Last updated - 26 Nov 2017
'This macro requires the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook

Dim oOutlookApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlRng As Range
Dim rngTo As Range
Dim rngCc As Range
Dim rngSubject As Range

    With ActiveSheet
        Set rngTo = .Cells(22, "B")
        Set rngCc = .Cells(24, "B")
        Set rngSubject = .Cells(26, "B")
        'Set rngBody = .Range("B28")
        'Set rngAttach = .Range("B4")
    End With

    Set xlRng = Range("A1:G20")    'The range to be copied
    xlRng.Copy    'Copy it
    Set oOutlookApp = OutlookApp()    'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to open Outlook, or it will not work correctly
    'Create a new mailitem
    Set oItem = oOutlookApp.CreateItem(0)
    With oItem
        .BodyFormat = 2    'html
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor    'access the message body for editing
        Set oRng = wdDoc.Range
        oRng.Collapse 1    'set a range to the start of the message
        oRng.Text = "This is the message body before the Excel range:" & vbCr & vbCr
        'Collapse the range to its end
        oRng.Collapse 0
        oRng.Text = vbCr & "This is the text after the Excel range."
        'The range will be followed by the signature associated with the mail account
        'collapse the range to its start
        oRng.Collapse 1
        'paste the excel range in the message
        oRng.Paste
        'Address the message
        .To = rngTo.value
        .CC = rngCc.value
        'Give it a title
        .Subject = rngSubject.value
        'attach the workbook
        .Attachments.Add ActiveWorkbook.FullName
        'display the message - this line is required even if you then add the command to send the message
        .Display
    End With

    'Clean up
    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set xlRng = Nothing
    Set rngTo = Nothing
    Set rngCc = Nothing
    Set rngSubject = Nothing
lbl_Exit:
    Exit Sub
End Sub

---