Excel VBA将Word正文作为Word文档中的文本添加 [英] Excel VBA add Email body as text from a word document

问题描述

如何将电子邮件发送给各个人，这些人将附加个性化的文档并将电子邮件正文的一部分设置为来自word文档的文本(个性化寻址，然后是来自Word的正文，然后是我的签名).

How do I send Emails to various people attaching individualized documents and setting parts of the Email body as text from a word document (Individualized Addressing, then the Body from Word and then my signature).

现在，除了电子邮件的正文以外，其他所有东西都起作用. 非常感谢您的帮助.

Right now everything works except of the body for the Emails. I'd really appreciate your help.

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

推荐答案

下面是一个简单的示例，该示例将复制整个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

这篇关于Excel VBA将Word正文作为Word文档中的文本添加的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！