如何在Word VBA执行邮件合并发送邮件时添加邮件正文

通过Word邮件合并功能实现自动化邮件发送时，使用如下VBA代码可完成批量发信，但发出的邮件无正文内容，需要补充邮件正文说明信息，咨询具体实现方式或替代方案。

Private Sub Send_EmailUsingMaiIMerge_Click()

Dim Wd_App As Word.Application
Dim Wd_Doc As Word.Document
Dim Wd_MailMerge As Word.MailMerge
Dim Data_Path As String
Dim Wd_MMFNs As Word.MailMergeFieldNames
Dim Wd_MMFN As Word.MailMergeFieldName
Dim Wd_MMDFs As Word.MailMergeDataFields
Dim Wd_MMDF As Word.MailMergeDataField

Set Wd_App = Application
Set Wd_Doc = Wd_App.Documents.Open("template.docx")
Set Wd_MailMerge = Wd_Doc.MailMerge

'获取数据路径
Data_Path = "Sheet.xlsx"

'设置邮件合并文档类型
Wd_MailMerge.MainDocumentType = wdFormLetters

'连接数据源
Wd_MailMerge.OpenDataSource Name:=Data_Path, SQLStatement:="SELECT * FROM [Sheet1$]"

'通过邮件合并发信，需提前打开Outlook并保持网络连接
Dim TotalCnt As Integer

For TotalCnt = 1 To Wd_MailMerge.DataSource.RecordCount
    Wd_MailMerge.DataSource.ActiveRecord = TotalCnt
    Wd_MailMerge.DataSource.FirstRecord = TotalCnt
    Wd_MailMerge.DataSource.LastRecord = TotalCnt
        
    '指定收件人邮箱字段
    Wd_MailMerge.MailAddressFieldName = "Email"
    '设置合并内容作为附件发送
    Wd_MailMerge.MailAsAttachment = True
    '设置邮件主题
    Wd_MailMerge.MailSubject = "Email Subject Test"
    '设置合并结果发送到邮件
    Wd_MailMerge.Destination = wdSendToEmail
    
    '执行合并
    Wd_MailMerge.Execute False
    
Next TotalCnt

Wd_Doc.Close False
Set Wd_Doc = Nothing
End Sub

邮件无正文核心是两处设置导致：

• 代码中Wd_MailMerge.MailAsAttachment = True参数会将合并生成的Word文档直接作为邮件附件发送，原生逻辑下不会自动填充邮件正文
• 引用的template.docx模板未编辑正文内容时，即使关闭附件发送模式，也不会生成有效正文

方案1：直接使用Word模板作为邮件正文（原生邮件合并逻辑，操作最简单） #

• 打开代码引用的template.docx，直接在文档内编辑需要的邮件正文内容，需要随收件人动态变化的内容（如姓名、专属信息），直接插入对应邮件合并域即可，编辑方式和普通邮件合并模板完全一致
• 将代码中Wd_MailMerge.MailAsAttachment = True修改为Wd_MailMerge.MailAsAttachment = False，执行合并时，模板内容会自动替换合并域后作为邮件正文发送

注意：该方案原生不支持「正文+自定义附件」同时存在，需要该能力请使用方案2

方案2：调用Outlook对象自定义发信（支持正文+附件、个性化HTML正文） #

遍历数据源时不直接通过邮件合并发信，先生成单条记录的合并临时文档，再主动调用Outlook创建邮件，自由配置正文、附件、收件人信息后发送，参考代码如下：

Private Sub Send_EmailUsingMailMerge_Click()
    Dim Wd_App As Word.Application
    Dim Wd_Doc As Word.Document
    Dim Wd_MailMerge As Word.MailMerge
    Dim Data_Path As String
    Dim Ol_App As Object
    Dim Ol_Mail As Object
    Dim TotalCnt As Integer
    Dim TempDocPath As String
    
    Set Wd_App = Application
    Set Wd_Doc = Wd_App.Documents.Open("template.docx")
    Set Wd_MailMerge = Wd_Doc.MailMerge
    
    '初始化Outlook应用对象
    On Error Resume Next
    Set Ol_App = GetObject(, "Outlook.Application")
    If Ol_App Is Nothing Then Set Ol_App = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Data_Path = "Sheet.xlsx"
    Wd_MailMerge.MainDocumentType = wdFormLetters
    Wd_MailMerge.OpenDataSource Name:=Data_Path, SQLStatement:="SELECT * FROM [Sheet1$]"
    
    '设置临时文件存储路径
    TempDocPath = Environ("TEMP") & "\temp_merge_doc.docx"
    
    For TotalCnt = 1 To Wd_MailMerge.DataSource.RecordCount
        '定位当前待发送记录
        Wd_MailMerge.DataSource.ActiveRecord = TotalCnt
        Wd_MailMerge.DataSource.FirstRecord = TotalCnt
        Wd_MailMerge.DataSource.LastRecord = TotalCnt
        
        '合并单条记录生成临时文档
        Wd_MailMerge.Destination = wdSendToNewDocument
        Wd_MailMerge.Execute False
        Wd_App.ActiveDocument.SaveAs2 TempDocPath
        Wd_App.ActiveDocument.Close False
        
        '创建自定义邮件项
        Set Ol_Mail = Ol_App.CreateItem(0)
        With Ol_Mail
            .To = Wd_MailMerge.DataSource.DataFields("Email").Value
            .Subject = "Email Subject Test"
            '自定义HTML正文，可自由编辑内容、拼接数据源字段实现个性化
            .HTMLBody = "<p>您好：</p><p>本次为您发送对应文档，详情见附件，如有问题请及时反馈。</p>"
            '添加合并生成的文档作为附件，不需要附件可删除该行
            .Attachments.Add TempDocPath
            '需要预览邮件请改用 .Display，确认无问题可直接发送用 .Send
            .Send
        End With
        
        '清理临时资源
        Set Ol_Mail = Nothing
        Kill TempDocPath
    Next TotalCnt
    
    Wd_Doc.Close False
    Set Ol_App = Nothing
    Set Wd_Doc = Nothing
    Set Wd_App = Nothing
End Sub

• 该方案支持自定义富文本/HTML格式正文，可灵活插入换行、加粗、链接等格式，也可直接读取数据源字段拼接个性化正文
• 首次调用Outlook对象时可能触发程序安全提示，选择允许操作即可正常运行

内容的提问来源于stack exchange，提问作者saravanan G