VBA send excel cells as body text

[zeerava]

Hi,

i have been trying to use the below code to send a specific cells via email as body txt.
Sub Email()
Dim rng As Range
Dim Outapp As Object
Dim outmail As Object


Set rng = Nothing
On Error Resume Next
Set rng = Sheets("EmailReport").Range("B1:N1007")
Set rng = rng.SpecialCells(xlCellTypeVisible)
rng.Copy
On Error GoTo 0


If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If


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


Set Outapp = CreateObject("Outlook.Application")
Set outmail = Outapp.CreateItem(0)
With outmail
.subject = "Daily Deal Checks " & Date
.body = "Good Morning," & vbNewLine & vbNewLine & "Queries from today's checks:" & vbNewLine & vbNewLine & RangeToHTML(rng)
.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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML = ts.ReadAll
ts.Close
RangeToHTML = Replace(RangeToHTML, "align=center xublishsource=", _
"align=left xublishsource=")

' Close TempWB.
TempWB.Close savechanges:=False

' Delete the htm file.
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

it sort of works the only issue is that rangetoHTML does not copies actual table and the txt comes out like this:
xmlns:x="urn:schemas-microsoft-comffice:excel"
xmlns="HTML 4.01 Specification">

****** http-equiv=Content-Type content="text/html; charset=windows-1252">
****** name=ProgId content=Excel.Sheet>
****** name=Generator content="Microsoft Excel 15">