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