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

以下是使用strbody

复制整个Word文档并将其添加到电子邮件正文的快速示例

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

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

1 个答案: