Excel VBA将电子邮件正文添加为word文档中的文本

Question

如何向各种人发送电子邮件，附加个性化文档并将电子邮件正文的某些部分设置为 word 文档中的文本（个性化寻址，然后是 Word 中的正文，然后是我的签名）。

现在一切正常，除了电子邮件的正文。 非常感谢您的帮助。

Sub Send_Files()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim html, name, address, age, department
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim Doc As String
    Dim wb1 As Workbook
    Dim Fname1 As String
    Dim strbody As String

    Doc = Range("E37").Value
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)
    Word.Selection.WholeStory
    Word.Selection.Copy
    strbody = ActiveSheet.Paste
    WordDoc.Close
    Word.Quit

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Daten")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
            '.Display 'here

                .To = cell.Value
                .CC = Range("Input!E4").Value
                .Subject = Range("F1").Value
                .HTMLBody = "<br>" & Range("A45").Value & "<br>" & strTemp & "<br>" & .HTMLBody

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

            .Display 'here

            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

Answer 1

这是一个快速示例，它将复制整个 Word 文档并使用 strbody 将其添加到电子邮件正文中

Option Explicit
Public Sub Example()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim Doc As String
    Dim strbody As String

    Doc = Range("E37").Text
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)
        Word.Selection.WholeStory
        strbody = Word.Selection

    Debug.Print strbody

    WordDoc.Close
    Word.Quit

    Set sh = Sheets("Daten")
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = cell.Value
                .CC = ""
                .Subject = Range("F1").Value
                .HTMLBody = "<br>" & Range("A45").Value & _
                            "<br>" & strbody & "<br>" & .HTMLBody

                .Display 'here
            End With
        End If
    Next 'cell

End Sub

---

要保留格式和签名，请尝试以下示例

Option Explicit
Public Sub Example()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim rng As Range
    Dim Word As New Word.Application
    Dim WordDoc As Word.Document
    Dim wdDoc As Word.Document
    Dim Doc As String
    Dim strbody As Variant ' String

    Doc = Range("E37").Text
    Set WordDoc = Word.Documents.Open(Doc, ReadOnly:=True)

    Word.Selection.WholeStory
    Word.Selection.Copy

    WordDoc.Close
    Word.Quit

    Set sh = Sheets("Daten")
    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            Set WordDoc = OutMail.GetInspector.WordEditor

            With OutMail
                .To = cell.Value
                .CC = ""
                .Subject = Range("F1").Value
                .Display 'here

                 WordDoc.Paragraphs(1).Range. _
                         InsertBefore sh.Range("A45").Value

                 WordDoc.Paragraphs(2).Range. _
                         PasteAndFormat Type:=wdFormatOriginalFormatting
            End With
        End If
    Next 'cell
End Sub