Dim WithEvents wdapp As Application
Dim EMAIL_SUBJECT As String
Dim FIRST_RECORD As Boolean


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)
    Dim i As Integer
    
    With ActiveDocument.MailMerge
    
        If FIRST_RECORD = True Then
            EMAIL_SUBJECT = .MailSubject
            FIRST_RECORD = False
        Else: .MailSubject = EMAIL_SUBJECT
        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)

    FIRST_RECORD = True
    
End Sub

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

    ActiveDocument.MailMerge.MailSubject = EMAIL_SUBJECT
     
End Sub