如何在Word VBA中正确实现MailMergeAfterRecordMerge事件？

问题背景 #

使用Office 2013，.docm与.xlsx邮件合并连接正常，宏手动运行正常，但Application.MailMergeAfterRecordMerge事件无法在每条合并记录后触发，目标是让MakeStuffHappen子程序在每条记录合并后运行，填充文档变量字段保证打印数据完整。

原代码结构 #

ThisDocument模块（测试版） #

Public WithEvents MailMergeApp As Word.Application

Private Sub MailMergeApp_MailMergeAfterRecordMerge(ByVal Doc As Document)

    With Doc.MailMerge.DataSource
        MsgBox .DataFields("FIRST_NAME").Value & " " & .DataFields("LAST_NAME").Value & " is the current record being merged."
    End With

End Sub

Dim X As EventClassModule

Sub DoTheMerge()
    Set X = New EventClassModule
    Set X.MailMergeApp = Word.Application
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .Execute
    End With
    Set X.MailMergeApp = Nothing
    Set X = Nothing
End Sub

EventClassModule类模块 #

Public WithEvents App As Word.Application

Dim X As New EventClassModule
Sub Register_Event_Handler()
    Set X.App = Word.Application
End Sub

业务逻辑与数据源连接代码 #

ThisDocument模块（业务逻辑）

Public WithEvents myApp As Word.Application
Public myDoc As Document
Public myMerge As MailMerge
Public myField As MailMergeDataField
Public myFields As MailMergeDataFields
Public myFieldName As MailMergeFieldName
Public myFieldNames As MailMergeFieldNames
Public mySource As MailMergeDataSource

Function chkArray(myArray, myItem)

chkArray = False

For i = LBound(myArray) To UBound(myArray)
    If myArray(i) = myItem Then
        chkArray = True
        Exit For
    End If
Next

End Function

Sub MakeStuffHappen()

Set myApp = Application
Set myDoc = myApp.ActiveDocument
Set myMerge = myDoc.MailMerge
Set myFields = myMerge.DataSource.DataFields

Dim myProduct As String

myProduct = myFields("PRODUCT").Value

Dim grp1, grp2, grp3 As Variant

grp1 = Array("APPLE", "ORANGE", "PEAR", "PEACH", "TANGERINE")
grp2 = Array("VODKA", "GIN", "WHISKY", "BOURBON")
grp3 = Array("WALNUT", "PECAN", "ALMOND", "CASHEW", "PEANUT", "HAZELNUT")

Dim test1, test2, test3 As Boolean

test1 = chkArray(grp1, myProduct)
test2 = chkArray(grp2, myProduct)
test3 = chkArray(grp3, myProduct)

Dim priceGrp As Currency, grpArray As Variant, grpName As String

If test1 = True Then
    grpArray = grp1
    grpName = "Fruits"
    priceGrp = ActiveDocument.Bookmarks("Fruit_Price").Range
ElseIf test2 = True Then
    grpArray = grp2
    grpName = "Liquors"
    priceGrp = ActiveDocument.Bookmarks("Liquor_Price").Range
ElseIf test3 = True Then
    grpArray = grp3
    grpName = "Nuts"
    priceGrp = ActiveDocument.Bookmarks("Nut_Price").Range
End If

Dim startDate As Date, timespan As Integer, endDate As Date

startDate = myFields("START_DATE").Value
timespan = myFields("YEARS").Value
endDate = DateAdd("yyyy", timespan, startDate)

Dim fullPrice, payMe1, payMe2 As Variant

If timespan = 1 Then
    fullPrice = priceGrp * 0.5 + 25
    payMe1 = fullPrice
    payMe2 = ""
ElseIf timespan = 2 Then
    fullPrice = priceGrp
    payMe2 = fullPrice * 0.5
    payMe1 = payMe2 + 25

ElseIf timespan = 0 Then
    fullPrice = ""
    payMe1 = ""
    payMe2 = ""
End If

ActiveDocument.Variables("END_DATE").Value = Format(endDate, "yyyy-mm-dd")
ActiveDocument.Variables("PRICE").Value = "$" + Format(fullPrice, "#0.00")
ActiveDocument.Variables("PAY1").Value = "$" + Format(payMe1, "#0.00")
ActiveDocument.Variables("PAY2").Value = "$" + Format(payMe2, "#0.00")
ActiveDocument.Fields.Update

Debug.Print Chr(34) + myProduct + Chr(34) + " is part of " + Chr(34) + grpName + Chr(34) + " (" + Join(grpArray, ", ") + ")"
Debug.Print "Price is $" + CStr(priceGrp)
Debug.Print "Start Date is " + Format(startDate, "yyyy-mm-dd")
Debug.Print "duration is: " + CStr(timespan) + " year(s)"
Debug.Print "end date: " + Format(endDate, "yyyy-mm-dd")
Debug.Print "Price: $" + Format(fullPrice, "#0.00")
Debug.Print "Payment #1 is: $" + Format(payMe1, "#0.00")
Debug.Print "Payment #2 is: $" + Format(payMe2, "#0.00")

End Sub

AutoOpen模块（数据源连接）

Sub ConnectToSpreadsheet()
'
' ConnectToSpreadsheet Macro created by the Record Macro Wizard, renamed the Module to AutoOpen so it fires when document opens

    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:="C:\VBAstuff\testList.xlsx", _
         ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:=
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\VBAstuff\testList.xlsx;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking Mode=0;Jet OL" _
        , SQLStatement:="SELECT * FROM `CUSTOMERS$`", SQLStatement1:="", SubType _
        :=wdMergeSubTypeAccess
End Sub

最简数据源连接代码

Sub AutoOpen()

    ' Procedure to connect to the xlsx data source

    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource _
    Name:="C:\VBAstuff\testList.xlsx", _
    Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\VBAstuff\testList.xlsx;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking Mode=0;Jet OL", _
    SQLStatement:="SELECT * FROM `CUSTOMERS$`"

End Sub

核心问题分析 #

1. 事件对象过早释放：原代码在DoTheMerge中注册事件后立即释放对象，导致事件还未触发就失去监听。
2. 类模块代码冗余：EventClassModule中重复声明实例，造成无效注册或循环引用。
3. 上下文混淆：MakeStuffHappen依赖ActiveDocument，合并时激活的是新生成文档，无法正确读取主文档书签数据。
4. 事件与业务逻辑脱节：测试用事件过程未调用MakeStuffHappen，无法实现目标功能。

具体修正步骤 #

1. 重构EventClassModule类模块 #

删除冗余代码，直接绑定事件并调用业务逻辑：

Public WithEvents App As Word.Application

Private Sub App_MailMergeAfterRecordMerge(ByVal Doc As Document)
    ' 触发业务逻辑，传入当前合并的文档
    Call ThisDocument.MakeStuffHappen(Doc)
End Sub

2. 修正ThisDocument模块 #

• 保留全局事件实例避免被回收，调整MakeStuffHappen接收文档参数，区分主文档与合并后文档的上下文：

' 全局变量保存事件类实例，确保合并过程中对象存活
Private X As EventClassModule

Sub DoTheMerge()
    Set X = New EventClassModule
    Set X.App = Word.Application
    
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .Execute
    End With
    
    ' 合并完成后再释放对象（若需多次合并可保留实例）
    ' Set X.App = Nothing
    ' Set X = Nothing
End Sub

Function chkArray(myArray, myItem) As Boolean
    chkArray = False
    Dim i As Integer
    For i = LBound(myArray) To UBound(myArray)
        If myArray(i) = myItem Then
            chkArray = True
            Exit For
        End If
    Next
End Function

Sub MakeStuffHappen(ByVal Doc As Document)
    Dim myMerge As MailMerge
    Dim myFields As MailMergeDataFields
    Set myMerge = Doc.MailMerge
    Set myFields = myMerge.DataSource.DataFields

    Dim myProduct As String
    myProduct = myFields("PRODUCT").Value

    Dim grp1, grp2, grp3 As Variant
    grp1 = Array("APPLE", "ORANGE", "PEAR", "PEACH", "TANGERINE")
    grp2 = Array("VODKA", "GIN", "WHISKY", "BOURBON")
    grp3 = Array("WALNUT", "PECAN", "ALMOND", "CASHEW", "PEANUT", "HAZELNUT")

    Dim test1, test2, test3 As Boolean
    test1 = chkArray(grp1, myProduct)
    test2 = chkArray(grp2, myProduct)
    test3 = chkArray(grp3, myProduct)

    Dim priceGrp As Currency, grpArray As Variant, grpName As String
    priceGrp = 0 ' 设置默认值，避免未匹配分组时出错
    If test1 = True Then
        grpArray = grp1
        grpName = "Fruits"
        priceGrp = ThisDocument.Bookmarks("Fruit_Price").Range ' 从主文档读取书签数据
    ElseIf test2 = True Then
        grpArray = grp2
        grpName = "Liquors"
        priceGrp = ThisDocument.Bookmarks("Liquor_Price").Range
    ElseIf test3 = True Then
        grpArray = grp3
        grpName = "Nuts"
        priceGrp = ThisDocument.Bookmarks("Nut_Price").Range
    End If

    Dim startDate As Date, timespan As Integer, endDate As Date
    startDate = myFields("START_DATE").Value
    timespan = myFields("YEARS").Value
    endDate = DateAdd("yyyy", timespan, startDate)

    Dim fullPrice, payMe1, payMe2 As Variant
    fullPrice = ""
    payMe1 = ""
    payMe2 = ""
    If timespan = 1 Then
        fullPrice = priceGrp * 0.5 + 25
        payMe1 = fullPrice
        payMe2 = ""
    ElseIf timespan = 2 Then
        fullPrice = priceGrp
        payMe2 = fullPrice * 0.5
        payMe1 = payMe2 + 25
    End If

    ' 更新当前合并后的文档变量
    Doc.Variables("END_DATE").Value = Format(endDate, "yyyy-mm-dd")
    Doc.Variables("PRICE").Value = "$" & Format(fullPrice, "#0.00")
    Doc.Variables("PAY1").Value = "$" & Format(payMe1, "#0.00")
    Doc.Variables("PAY2").Value = "$" & Format(payMe2, "#0.00")
    Doc.Fields.Update

    ' 调试输出
    Debug.Print """" & myProduct & """ is part of """ & grpName & """ (" & Join(grpArray, ", ") & ")"
    Debug.Print "Price is $" & CStr(priceGrp)
    Debug.Print "Start Date is " & Format(startDate, "yyyy-mm-dd")
    Debug.Print "duration is: " & CStr(timespan) & " year(s)"
    Debug.Print "end date: " & Format(endDate, "yyyy-mm-dd")
    Debug.Print "Price: $" & Format(fullPrice, "#0.00")
    Debug.Print "Payment #1 is: $" & Format(payMe1, "#0.00")
    Debug.Print "Payment #2 is: $" & Format(payMe2, "#0.00")
End Sub

3. 简化AutoOpen模块 #

使用最简连接字符串，确保模块与子程序命名规范：

Sub AutoOpen()
    ' 连接xlsx数据源
    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource _
        Name:="C:\VBAstuff\testList.xlsx", _
        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\VBAstuff\testList.xlsx;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;""", _
        SQLStatement:="SELECT * FROM `CUSTOMERS$`"
End Sub

关键注意事项 #

• 对象生命周期：事件类实例必须在合并全程保持存活，不能在Execute后立即释放。
• 上下文区分：主文档的书签数据从ThisDocument读取，合并后的文档操作使用传入的Doc参数，避免ActiveDocument的上下文错误。
• 变量声明：所有循环变量需显式声明，避免隐式变体类型引发的问题。

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