Selected Answer
DarkBlade
I think your code fails when you try to make the email body include a range of cells.
This can be solved with a solution from Ron de Bruin (as @Variatus says, the guru!). That is to take the cells (and your introductory text) and call Ron's function which converts a range of cells to HTML...
Please make cell F1 (or change the code below to the cell of your choice) to be Please see your report below: (and autofit the column width) then make the changes in bold below to your code and add the Function from Ron (with only name in bold) - or you can just copy the lot and drop it onto VB Editor since I've changed the email sub name to suit:
Sub EmailAsHTML()
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Dim r As Variant
Dim P As Range
Dim q As Range
Dim Rng As Range
Set objOutlook = CreateObject("Outlook.Application")
Set Rng = ActiveSheet.Range("A1:B5")
r = Application.WorksheetFunction.VLookup(Range("A1"), Sheet1.Range("C:D"), 2, 0)
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.to = r
.Subject = "This is a test message from Arun Banik"
'.Body = "please see your report below" & ActiveSheet.Range("A1:B5")
.HTMLBody = RangetoHTML(ActiveSheet.Range("F1")) & RangetoHTML(Rng)
.Display ' DISPLAY MESSAGE.
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'
End Sub
Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
It seems like a lot of code but it should do the job!
Hope this helps (if so please mark this Answer as Selected)