Issue VBA Copying/Displaying Table in Email Body

[DidierIV]

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

[Logit]

.


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

[gmayor]

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 -


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