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

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