Below is code I wrote to create a word document based on a template and bookmarks. I need to change the document to be able to include more than one record per letter I can't seem to figure it out.

Dim Host, he As Object
    Dim rstMailPrgrssvLtr As New ADODB.Recordset
    Dim rstMailPrgrssvLtr2 As New ADODB.Recordset
    Dim appWord As New Word.Application
    Dim truncate As String
    Dim Amount As String
    Dim acct As String
    Dim passacct As String
    Dim addrss As String
    Dim merch As String
    Dim count As String




    idletime = 600

        'Defines the MBNA Window as the Host.
    Set he = CreateObject("HostExplorer")
    Set Host = he.CurrentHost


    'Open a recordset based on the qryEmail query.

    rstMailPrgrssvLtr.Open "qryMailPrgrssv3", _
        CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    rstMailPrgrssvLtr2.Open "qryMailPrgrssv2", _
        CurrentProject.Connection, adOpenKeyset, adLockOptimistic

        'If no records exist, display a message and then exit.
        If rstMailPrgrssvLtr.RecordCount = 0 Then
            MsgBox "There are no Progressive Letters to Mail Today.", vbOKOnly, "Progressive Letter"
            Exit Function
        End If
        count = rstMailPrgrssvLtr.RecordCount
        truncate = Left$(rstMailPrgrssvLtr2!AccountNumber, 10)
        Amount = FormatCurrency(rstMailPrgrssvLtr!Amount)
        'Open a document based on the Email template. Turn off spell check.
        'move to the To line bookmark, and then display Word.
         MsgBox ("There are " & count & " Letters being created"), vbOKOnly, "Printing Ltrs"

        MsgBox "Make sure you are logged in to IS and on X100 Screen", vbOKOnly, "Documentation"

    Do Until rstMailPrgrssvLtr.EOF
        merch = rstMailPrgrssvLtr!Merchant
        acct = rstMailPrgrssvLtr2!AccountNumber
        truncate = Left$(rstMailPrgrssvLtr2!AccountNumber, 10)
        Amount = FormatCurrency(rstMailPrgrssvLtr!Amount)
        If rstMailPrgrssvLtr.Fields!FrenchDoc = True Then
            With appWord 'french document code
                .Documents.Add "G:\Risk Control\Fraud\Fraud Back End\Fraud Back End\Project\Affidavit\PrgrssvTemplates\Mailprogrsv LtrTemplateFREN060106.dot"
                .Selection.GoTo wdGoToBookmark, Name:="Trunkate"
                appWord.Selection.TypeText truncate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Name1"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Name & " "
                .Selection.GoTo wdGoToBookmark, Name:="Address"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Address & " "
                .Selection.GoTo wdGoToBookmark, Name:="City"
                appWord.Selection.TypeText rstMailPrgrssvLtr!City & " "
                .Selection.GoTo wdGoToBookmark, Name:="PostalCode"
                appWord.Selection.TypeText rstMailPrgrssvLtr!PostalCode & " "
                .Selection.GoTo wdGoToBookmark, Name:="Name2"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Name & " "
            Do Until rstMailPrgrssvLtr.Fields!AccntId <> rstMailPrgrssvLtr2.Fields!AccountNumber
                .Selection.GoTo wdGoToBookmark, Name:="Amount"
                appWord.Selection.TypeText Amount & " "
                .Selection.GoTo wdGoToBookmark, Name:="Merchant"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Merchant & " "
                .Selection.GoTo wdGoToBookmark, Name:="TransDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!TransDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="DueDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!DueDate & " "
                Loop
                .Selection.GoTo wdGoToBookmark, Name:="Name3"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Name & " "
                .Selection.GoTo wdGoToBookmark, Name:="Trunkate2"
                appWord.Selection.TypeText truncate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Merchant2"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Merchant & " "
                .Selection.GoTo wdGoToBookmark, Name:="Amount2"
                appWord.Selection.TypeText Amount & " "
                .Selection.GoTo wdGoToBookmark, Name:="TransDate2"
                appWord.Selection.TypeText rstMailPrgrssvLtr!TransDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Reference"
                appWord.Selection.TypeText rstMailPrgrssvLtr!ReferenceNumber & " "
                .Visible = False
                appWord.ActiveDocument.SaveAs ("G:\Risk Control\Fraud\Fraud Back End\Fraud Back End\Project\Affidavit\PrgrssvTemplates\" & rstMailPrgrssvLtr!AccountNumber), wdFormatDocument
                appWord.ActiveDocument.PrintOut



                If Len(appWord.ActiveDocument.Path) = 0 Then
                MsgBox "Document needs to be saved first"

                End If









                appWord.ActiveDocument.Close


            End With





        Else 'English document code
            With appWord

                .Documents.Add "S:\Canada\Risk Control\Fraud\Fraud Back End\Fraud Back End\Project\Affidavit\PrgrssvTemplates\Mailprogrsv LtrTemplateEng060106.dot"
                .ActiveDocument.ShowSpellingErrors = False
                .Selection.GoTo wdGoToBookmark, Name:="Truncate"
                appWord.Selection.TypeText truncate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Name"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!Name & " "
                .Selection.GoTo wdGoToBookmark, Name:="Address"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!Address & " "
                .Selection.GoTo wdGoToBookmark, Name:="City"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!City & " "
                .Selection.GoTo wdGoToBookmark, Name:="PostalCode"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!PostalCode & " "
                .Selection.GoTo wdGoToBookmark, Name:="Name2"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!Name & " "
            Do Until rstMailPrgrssvLtr.Fields!AccntId <> rstMailPrgrssvLtr2.Fields!AccountNumber
                .Selection.GoTo wdGoToBookmark, Name:="Amount"
                appWord.Selection.TypeText Amount & " "
                .Selection.GoTo wdGoToBookmark, Name:="Merchant"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Merchant & " "
                .Selection.GoTo wdGoToBookmark, Name:="TransDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!TransDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="DueDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!DueDate & " "
                Loop
                .Selection.GoTo wdGoToBookmark, Name:="Amount"
                appWord.Selection.TypeText Amount & " "
                .Selection.GoTo wdGoToBookmark, Name:="Merchant"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Merchant & " "
                .Selection.GoTo wdGoToBookmark, Name:="TransDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!TransDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="DueDate"
                appWord.Selection.TypeText rstMailPrgrssvLtr!DueDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Name3"
                appWord.Selection.TypeText rstMailPrgrssvLtr2!Name & " "
                .Selection.GoTo wdGoToBookmark, Name:="Trunkate2"
                appWord.Selection.TypeText truncate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Merchant2"
                appWord.Selection.TypeText rstMailPrgrssvLtr!Merchant & " "
                .Selection.GoTo wdGoToBookmark, Name:="Amount2"
                appWord.Selection.TypeText Amount & " "
                .Selection.GoTo wdGoToBookmark, Name:="TransDate2"
                appWord.Selection.TypeText rstMailPrgrssvLtr!TransDate & " "
                .Selection.GoTo wdGoToBookmark, Name:="Reference"
                appWord.Selection.TypeText rstMailPrgrssvLtr!ReferenceNumber & " "
                .Visible = False
                appWord.ActiveDocument.SaveAs ("Location"End\Project\Affidavit\PrgrssvTemplates\ " & rstMailPrgrssvLtr2!AccountNumber), wdFormatDocument
                appWord.ActiveDocument.PrintOut


                If Len(appWord.ActiveDocument.Path) = 0 Then
                    MsgBox "Document needs to be saved first"
                End If




                appWord.ActiveDocument.Close

            End With

        End If

        rstMailPrgrssvLtr.Fields!MailLtr = True
        rstMailPrgrssvLtr2.Fields!LastModifiedDate = Date
        rstMailPrgrssvLtr.Fields!MailDate = Date
        rstMailPrgrssvLtr2.Fields!Notes = Date & " Letter Mailed"
        rstMailPrgrssvLtr.MoveNext




        rstMailPrgrssvLtr2.MoveNext


Loop

    MsgBox "All documents have been printed", vbOKOnly, "Mail Progressive Letter"
End Function