调用MailMergeDataSource查找函数后Word邮件合并执行失败问题

问题描述 #

通过Word VBA实现「搜索邮件合并数据源→执行单条记录邮件合并」的流程，两个步骤单独运行均正常，但连续调用时：

• 先调用SearchForDocument()找到目标记录编号后，再调用ExecuteMerge()会触发运行时错误‘5631’：Word无法将主文档与数据源合并，因为数据记录为空或没有数据记录匹配查询选项。
• 若先运行SearchForDocument()记录编号，关闭Word不保存后重新打开，再调用ExecuteMerge()则能成功执行。
• 尝试重置.ActiveRecord = 1无效。

原代码 #

搜索数据源函数 #

Function SearchForDocument(doc_id As String)
    ' Searches datasource for given record id number.
    
    Dim dsMain As MailMergeDataSource
    Dim numRecord As Integer
     
    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False
    Set dsMain = ActiveDocument.MailMerge.DataSource
    'Initializes at first record because .ActiveRecord method only searches for first match in descending records from current record
    dsMain.ActiveRecord = 1
 
    If dsMain.FindRecord(FindText:=doc_id, Field:="SAMPLE") = True Then
        numRecord = dsMain.ActiveRecord
    Else
        MsgBox "Record " & doc_id & " was not found."
        numRecord = 0
    End If
    
    SearchForDocument = numRecord
  
End Function

执行邮件合并函数 #

Function ExecuteMerge(ByVal TargetRecord As Integer)    
    Set myMerge = ActiveDocument.MailMerge
    If myMerge.State = wdMainAndSourceAndHeader Or _
     myMerge.State = wdMainAndDataSource Then
     With myMerge.DataSource
     .FirstRecord = TargetRecord
     .LastRecord = TargetRecord
     End With
    End If
    With myMerge
     .Destination = wdSendToNewDocument
     .Execute
     
    End With
   
End Function

问题原因 #

FindRecord方法执行后，Word会自动为数据源添加一个临时筛选条件，仅保留找到的匹配记录。后续ExecuteMerge中设置FirstRecord/LastRecord时，这个筛选条件依然生效，导致指定的记录编号（基于原始数据集的编号）无法匹配筛选后的数据集，从而触发错误。

解决方案 #

在搜索完成后清除数据源的筛选条件，确保后续合并时使用完整的数据集。

修改后的搜索函数 #

Function SearchForDocument(doc_id As String)
    ' Searches datasource for given record id number.
    
    Dim dsMain As MailMergeDataSource
    Dim numRecord As Integer
     
    ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False
    Set dsMain = ActiveDocument.MailMerge.DataSource
    'Initializes at first record because .ActiveRecord method only searches for first match in descending records from current record
    dsMain.ActiveRecord = 1
 
    If dsMain.FindRecord(FindText:=doc_id, Field:="SAMPLE") = True Then
        numRecord = dsMain.ActiveRecord
    Else
        MsgBox "Record " & doc_id & " was not found."
        numRecord = 0
    End If
    
    ' 清除FindRecord自动添加的筛选条件
    dsMain.Filter = ""
    
    SearchForDocument = numRecord
  
End Function

可选：在合并函数中重置筛选（双重保障） #

如果担心其他操作影响筛选状态，也可以在ExecuteMerge中先重置数据源的筛选和查询：

Function ExecuteMerge(ByVal TargetRecord As Integer)    
    Set myMerge = ActiveDocument.MailMerge
    If myMerge.State = wdMainAndSourceAndHeader Or _
     myMerge.State = wdMainAndDataSource Then
     With myMerge.DataSource
        ' 重置筛选和查询条件
        .Filter = ""
        .QueryString = ""
        ' 设置目标记录范围
        .FirstRecord = TargetRecord
        .LastRecord = TargetRecord
     End With
    End If
    With myMerge
     .Destination = wdSendToNewDocument
     .Execute
    End With
   
End Function

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