Sending Excel table in MailBody - excel

Question

I am using this code to send an e-mail via VBA, but I need to send a table as a Body.
This code sends only a one cell not a range.
How can I paste Range("B5:D10") as a table in mail body?
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("B1").Value
.Cc = Range("B2").Value
.Bcc = Range("B3").Value
.Subject = Range("B4").Value
.Body = Range("B5").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing

Answer 1

You can achieve that by setting HTMLBody instead of Body. But then, to have control over formatting of a message, you have to have basic konwledge of HTML.
The idea behind it is as follows: you have to put range content together with HTML tags like this:
Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
Set rng = Range("B5:D10")
HtmlContent = "<table>"
For i = 5 To rng.Rows.Count + 4
HtmlContent = HtmlContent & "<tr>"
For j = 2 To rng.Columns.Count + 2
HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
Then, to put this table in a message:
With OutMail
'...
.HTMLBody = HtmlContent
'...
End With

Answer 2

You can try like this.
Sub test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = Sheets("Sheet1").Range("B5:D10").SpecialCells(xlCellTypeVisible)
On Error Resume Next
With OutMail
.To = Range("B1").Value
.Cc = Range("B2").Value
.Bcc = Range("B3").Value
.Subject = Range("B4").Value
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0
Set OutMail = 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

Answer 3

You can't.
Thant body argument accept only Strings.
And there's another problem: formatting.
If I remember well I was in you situation and use something like this to produce html file from range.
Then I used TStream to take the ".html" file and put the result in the body.
Wrapping all this is in a pseudo:
Public Sub Email()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim FSObj As Scripting.FileSystemObject
Dim TStream As Scripting.TextStream
Dim rngeSend As Range
Dim strHTMLBody As String
'Select the range to be sent
Set rngeSend = Application.Range("B1:G35")
If rngeSend Is Nothing Then Exit Sub 'User pressed Cancel
On Error GoTo 0
'Now create the HTML file
ActiveWorkbook.PublishObjects.Add(xlSourceRange, "C:\sales\tempsht.htm", rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True
'Create an instance of Outlook (or use existing instance if it already exists
Set olApp = CreateObject("Outlook.Application")
'Create a mail item
Set olMail = olApp.CreateItem(olMailItem)
'Open the HTML file using the FilesystemObject into a TextStream object
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile("C:\sales\tempsht.htm", ForReading)
'Now set the HTMLBody property of the message to the text contained in the TextStream object
strHTMLBody = TStream.ReadAll
olMail.HTMLBody = strHTMLBody
olMail.To = "anybody#anywhere.com"
olMail.Subject = "Email Subject"
olMail.Send
Hope it helps!

Answer 4

The answer from saransh seems to be based on this solution by Ron de Bruin.
However, it has a flaw where cells that have text hidden by other cells will result in that text being cut off in the result.
This is because the html renders this text with style display:none.
A simple solution it to add a line when reading the html file.
After this line:
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
add:
RangetoHTML = Replace(RangetoHTML, "display:none", "")
This will result in the hidden text be displayed and the table to autosize the columns.

Answer 5

You can use this function below so that it return a string of html:
extracttablehtml(thisworkbook.worksheets("whatever"), range("A1:B5"))
Afterwards, you do:
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "anymail"
.Cc = ""
.Bcc = ""
.Subject = ""
.HTMLBody = extracttablehtml(thisworkbook.worksheets("whatever"), Range("A1:B5")) '<<<< Here it is
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
public function:
Public Function extracttablehtml(ws As Worksheet, rng As Range) As String
Dim HtmlContent As String, i As Long, j As Long
On Error GoTo 0
HtmlContent = "<table>"
For i = 1 To rng.Rows.Count
HtmlContent = HtmlContent & "<tr>"
For j = 1 To rng.Columns.Count
HtmlContent = HtmlContent & "<td>" & ws.Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
extracttablehtml = HtmlContent
Error_Handler_Exit:
On Error Resume Next
If Not rng Is Nothing Then Set OutMail = Nothing
Exit Function
Error_Handler:
If Alert = True Then
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: single_prop_write_mail_proposal" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
End If
Resume Error_Handler_Exit
End Function