vba - 如何拆分邮件合并并以合并字段作为名称保存文件

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

问题是，如果我“合并到新文档”，那么“FileNumber”字段不再存在，所以它无法拾取它，但如果我只是转到“预览结果”并运行宏，它只会保存当前预览的记录而不是其余的字母。

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

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

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

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

请记住，这段代码对处理器的负担可能很大。