Sunday, September 25, 2016

Word - Mail Merge a Document to Separate Files

I was asked to help mail merge a document and save the result to a file name based using values from the some merged fields. I found some code on Stack Overflow by Søren Francis and modified it to loop.
My steps:

Sub OutDoc()
' 1) Merges active record and saves the resulting document named by the datafield
' 2) Closes the resulting document, and advances to the next record in the datasource
' Based on code by Søren Francis 6/7-2013 at href="
    Dim DokName  As String   'ADDED CODE
    Dim strFolder As String
    Dim fDone As Boolean
    fDone = False
    ' Set the destination folder
    strFolder = "C:\Projects\ForAdam\FinalDocs\"
 ' Start at the first document
 ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
    ' Set the document name
           DokName = .DataFields("ResID").Value & .DataFields("First").Value & "_Contract"
        End With

    ' Merge the active record
        .Execute Pause:=False
    End With

    ' Save then resulting document. NOTICE MODIFIED filename
    ActiveDocument.SaveAs2 FileName:=strFolder + DokName + ".doc", FileFormat:= _
        wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _

    ' Close the resulting document

    ' Now, back in the template document, advance to next record if there is a next record
    If ActiveDocument.MailMerge.DataSource.ActiveRecord <> ActiveDocument.MailMerge.DataSource.RecordCount Then
        ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
    Else ' Flag that we are done
        fDone = True
    End If
  Loop Until fDone 
End Sub