Скопируйте текст и изображение из листа Excel в виде тела почты в Outlook

Question

Это пример электронной почты, который сохраняется в листе Excel.

Привет,

Это тестовое письмо

С уважением, Xyz

Я хочу, чтобы скопировать эту электронную почту, как это & вставить его Перспективы.

С помощью онлайновых форумов я написал код, но вывод не совпадает с входом.

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 

Ниже Выхода я получаю с выше кодом.
Ссылка для Ехчел: https://drive.google.com/open?id=0Byy709uTvWRoTnRYaVJQNWNNR1E

Answer 1

Использование GetInspector.WordEditor

См Пример ...

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