如何拆分邮件合并并使用合并字段作为名称保存文件

Question

我有一堆邮件合并模板设置，当我合并文档时，我想将结果拆分成单独的文件，每个文件的名称都基于合并字段“ FileNumber”。

我目前拥有的代码是：

Sub splitter()
' Based on a macro by Doug Robbins to save each letter created by a mailmerge as a separate file.
' With help from http://www.productivitytalk.com/forums/topic/3927-visual-basic-question-for-merge-fields/

Dim i As Integer
Dim Source As Document
Dim Target As Document
Dim Letter As Range
Dim oField As Field
Dim FileNum As String

Set Source = ActiveDocument

For i = 1 To Source.Sections.Count
    Set Letter = Source.Sections(i).Range
    Letter.End = Letter.End - 1
        For Each oField In Letter.Fields
        If oField.Type = wdFieldMergeField Then
            If InStr(oField.Code.Text, "FileNumber") > 0 Then
            'get the result and store it the FileNum variable
            FileNum = oField.Result
            End If
        End If
        Next oField
    Set Target = Documents.Add
    Target.Range = Letter
    Target.SaveAs FileName:="C:\Temp\Letter" & FileNum
    Target.Close
    Next i
End Sub

问题是，如果我“合并到新文档”，则“文件编号”字段不再存在，因此无法进行选择，但是如果我只是转到“预览结果”并运行宏，它将仅保存当前预览的记录，并且不是其余的字母。

我假设我需要将代码更改为类似

For i = 1 To Source.MergedRecord.Count
    Set Letter = Source.MergedRecord(i).Range

但我无法计算出正确的语法。

我知道http://www.gmayor.com/individual_merge_letters.htm，但是我不希望对话框中只单击一个按钮。

Answer 1

在邮件合并模板文档中，将以下宏代码粘贴到“ ThisDocument”模块中：

Dim WithEvents wdapp As Application
Dim bCustomProcessing As Boolean

Private Sub Document_Open()

Set wdapp = Application
bCustomProcessing = False
ThisDocument.MailMerge.DataSource.ActiveRecord = 1
ThisDocument.MailMerge.ShowWizard 1
With ActiveDocument.MailMerge
   If .MainDocumentType = wdFormLetters Then
       .ShowSendToCustom = "Custom Letter Processing"
   End If
End With

End Sub
Private Sub wdapp_MailMergeWizardSendToCustom(ByVal Doc As Document)

bCustomProcessing = True
Doc.MailMerge.Destination = wdSendToNewDocument
With Doc.MailMerge
    For rec = 1 To .DataSource.RecordCount
        .DataSource.ActiveRecord = rec
        .DataSource.FirstRecord = rec
        .DataSource.LastRecord = rec
        .Execute
    Next
End With

MsgBox "Merge Finished"
End Sub


Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)
If bCustomProcessing = True Then
    With Doc.MailMerge.DataSource.DataFields
        sFirmFileName = .Item(1).Value ' First Column of the data - CHANGE
    End With
    DocResult.SaveAs "c:\path\" & sFirmFileName & ".docx", wdFormatXMLDocument
     ' Path and File Name to save. can use other formats like wdFormatPDF too
    DocResult.Close False
End If
End Sub

记住要更新用于文件名的列号，以及用于保存生成的文件的路径。

编写此代码后，保存并关闭合并模板文档。重新打开文件，这一次将提示您合并菜单。按照字母的要求进行操作，并在最后一步中选择“ Custom Letter Processing”选项，而不是完成合并。这会将单独的合并文档保存在指定的文件夹中。

请记住，此代码在处理器上可能很繁琐。