从 Excel 打开 Word 文档并将内容粘贴到 Outlook 邮件的正文

Question

我想从 Excel 中通过 MS Outlook 发送自动邮件。

问题是写邮件的正文。我在 Excel 单元格中为每个员工创建了一个单独的 Word 文件，并带有指向它的超链接。我想打开 Word 文件并以相同的格式复制 Word 文档中的所有内容，然后粘贴到邮件正文中。

在我的 Excel 工作簿中，A 到 E 列如下所示。

A 列：员工姓名
B 列：至邮件 ID
C 栏：抄送邮件 ID
D 列：主题
E栏：Word文件的超链接（需要打开文件复制粘贴到邮件正文中）
F 到 Z 列：附件（任何类型的附件）

Sub Send_Files()

'Make a list in Sheets("Sheet1") with :

'In column A : Names of the people
'In column B : E-mail addresses
'In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

'The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
'and file name(s) in column C:Z it will create a mail with this information and send it.

'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

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

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

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

    'Enter the path/file names in the C:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

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

        With OutMail
            .to = cell.Value
            .cc = cell.Offset(0, 1).Value
            .Subject = cell.Offset(0, 2).Value
            .Body = "Hi" & cell.Offset(0, -1).Value
            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

            .Send  'Or use .Display
        End With
        Set OutMail = Nothing
    End If[enter link description here][1]
Next cell
Set OutApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

邮件正文的快照。

Answer 1

诀窍在于获取粘贴格式的 Word 文档内容。为此，您需要附加 MS Word 是 Outlook 邮件项目的编辑器。

此外，从上面的示例 Word 文档中，您希望为用户个性化电子邮件。所以修改Word文档为“Dear XXXNAMEXXX”，然后执行查找/替换（如代码所示）。

Option Explicit

Sub Send_Files()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutMailEditor As Object
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

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

    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    Set WordApp = CreateObject("Word.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("F1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            'copy/paste the body of the email and change the name
            Set OutMailEditor = OutMail.GetInspector.WordEditor
            Set WordDoc = WordApp.documents.Open(Filename:=cell.Offset(0, 3).Value, ReadOnly:=True)
            WordDoc.Content.Copy
            OutMailEditor.Range.Paste
            With OutMailEditor.Range.Find
                .Text = "XXXNAMEXXX"
                .Replacement.Text = cell.Offset(0, -1).Value
                .Wrap = 1
                .Forward = True
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=2
            End With

            With OutMail
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .Subject = cell.Offset(0, 2).Value
                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

                .Send  'Or use .Display
            End With
            Set OutMail = Nothing
            Set WordDoc = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    Set WordApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub