Excel vba paste range into email body as picture

[Prabhu]

Hi All,

I am using the below code to copy range from excel to Outlook Mail body. Now i want to past the copied range from excel to outlook as image instead of value.

Kindly help to modify the below code.

Option Explicit
Sub Mail()

Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Dim Msg As String, Ans As Variant
Dim strBody1 As String

Dim LTime As String

Dim rng1 As Range
Set wSheetStart = ActiveSheet
' Set Sourcewb = ActiveWorkbook
'Set rng1 = Nothing


Dim OutApp As Object, OutMail As Object
Dim LR As Long, LC As Long
Dim fName As String, sFname As String, sPath As String
Set rng1 = Nothing

With Sheets("Sheet1")
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rng1 = .Range(.Cells(1, 1), .Cells(LR, LC)).SpecialCells(xlCellTypeVisible)
End With

With ActiveWorkbook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)




With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = rangetoHTML(rng1)
'.Attachments.Add ActiveWorkbook.FullName
.Importance = 2
.display
'.send
End With

Set OutMail = Nothing
Set OutApp = Nothing
'' ActiveWorkbook.Close True
' Kill sPath & sFname
End With


End Sub


Function range1toHTML(rng1 As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook


TempFile = Environ$("temp") & "\" & Format(Now, "dd-mmm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng1.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)
range1toHTML = ts.readall
ts.Close
range4toHTML = Replace(range4toHTML, "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