Copy text and image from Excel sheet as mail body to Outlook - excel

Question

This is the sample email which is saved in Excel worksheet.
Hi All,
This is the test email
Regards,
Xyz
I want to copy this email as it is & paste it to Outlook.
With the help of online forums I have written a code but the output is not the same as the input.
Global Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String
Global Mail_Object, Mail_Single As Variant
Global wb As Workbook
Sub India_BB()
Dim i As Integer
Dim ShtToSend As Worksheet
Dim strSendTo, strbody As String
Dim strSheetName As String
Dim strSubject As String
Dim rng As Range
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = "India_BB" Then
Sheets(i).Select
Set rng = Nothing
strSheetName = Sheets(i).Name
strSendTo = Sheet1.Range("A1").Text
strSubject = Sheet1.Range("B1").Text
Set rng = Sheets(strSheetName).Range("body").SpecialCells(xlCellTypeVisible)
With Mail_Single
.To = strSendTo
.CC = ""
.BCC = ""
.Subject = strSubject
.HTMLBody = RangetoHTML(rng)
.Display
End With
End If
Next i
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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 xlPasteAll, , 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
Below is the Output I am getting with above code.
Link for excel file : https://drive.google.com/open?id=0Byy709uTvWRoTnRYaVJQNWNNR1E

Answer 1

Use GetInspector.WordEditor
See Example...
Sub India_BB()
Dim i As Integer
Dim ShtToSend As Worksheet
Dim strSendTo, strbody As String
Dim strSheetName As String
Dim strSubject As String
Dim rng As Range
' add ref - tool -> references - > Microsoft Word XX.X Object Library
Dim wdDoc As Word.Document '<=========
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
Set wdDoc = Mail_Single.GetInspector.WordEditor '<========
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = "India_BB" Then
Sheets(i).Select
Set rng = Nothing
strSheetName = Sheets(i).Name
strSendTo = Sheet1.Range("A1").Text
strSubject = Sheet1.Range("B1").Text
Set rng = Sheets(strSheetName).Range("body").SpecialCells(xlCellTypeVisible)
rng.Copy
With Mail_Single
.To = strSendTo
.CC = ""
.BCC = ""
.Subject = strSubject
' .HTMLBody = RangetoHTML(rng)
.Display
wdDoc.Range.PasteAndFormat wdChartPicture & .HTMLBody = " " '<=======
End With
End If
Next i
End Sub