Mail Merge - Dynamic subject line? (2 Viewers)

Public WithEvents wdapp As Word.Application

Dim ORIG_EMAIL_SUBJECT As String
Dim FIRST_RECORD As Boolean

'Open MailMerge Wizard when document is opened
Private Sub Document_Open()

    Set wdapp = Application
    ThisDocument.MailMerge.ShowWizard 1
  
End Sub

Private Sub Document_Close()

    Set wdapp = Nothing
    
End Sub

Private Sub wdapp_MailMergeBeforeRecordMerge(ByVal Doc As Document, Cancel As Boolean)
    'Called once per record (row in spreadsheet).
    
    Dim i As Integer
        
    With ActiveDocument.MailMerge
        
        'Get or reset the .MailSubject MailMerge property
        If FIRST_RECORD = True Then
            ORIG_EMAIL_SUBJECT = .MailSubject
            FIRST_RECORD = False 'Set the flag so it won't change the ORIG_EMAIL_SUBJECT anymore
            
        Else:
            .MailSubject = ORIG_EMAIL_SUBJECT 'Reset from customized .MailSubject back to original for next mailmerge iteration
                      
        End If

        i = .DataSource.DataFields.Count
        
        Do While i > 0
        
            .MailSubject = Replace(.MailSubject, "<" & .DataSource.DataFields(i).Name & ">", .DataSource.DataFields(i).Value, , , vbTextCompare)
            i = i - 1
            
        Loop
    End With
    
End Sub

Private Sub wdapp_MailMergeBeforeMerge(ByVal Doc As Document, ByVal StartRecord As Long, ByVal EndRecord As Long, Cancel As Boolean)

    'Initialize for first use
    FIRST_RECORD = True
    
End Sub

Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)

    'Reset back to original when done.
    ActiveDocument.MailMerge.MailSubject = ORIG_EMAIL_SUBJECT
    
End Sub