将 Excel 工作表中的文本和图像作为邮件正文复制到 Outlook

Question

这是保存在 Excel 工作表中的示例电子邮件。

大家好，

这是测试邮件

问候， xyz

我想按原样复制此电子邮件并将其粘贴到 Outlook。

在网上论坛的帮助下，我写了一段代码，但输出与输入不一样。

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