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

Question

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

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

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

A列:员工姓名
B 列:收件人 ID
C 列:CC 邮件 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 文档修改为“亲爱的 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