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

Question

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

  

     

大家好，

     

这是测试电子邮件

     

此致   XYZ

我想复制这封电子邮件，因为它是＆amp;将其粘贴到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