將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 

下面是我用上面的代碼獲取輸出。
鏈接Excel文件：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