Adding pages to a template using VBA

Question

Hello

Greetings

I have a single page template which i use to create over 100 payment vouchers for contractors( data is obtained from a record set in access Database)

The code i have currently can create separate documents from the  template i.e  100 word documents./files and save them.

What i want if it is possible to a create a single word document with say the 100 pages . Each page for the contractor

Here is the complete code

Private Sub cmdCreate_Click()

Dim db As DAO.Database

Dim rst As DAO.Recordset

Dim strSQL As String

Dim strFilePath As String

Dim strName As String

Dim strTemp As String

Dim icount As Integer

Dim objWord As Word.Application

Dim wrdDoc As Word.Document

Dim objRange As Word.Range

Dim intCount As Integer

Dim strMsg As String

strSQL = " SELECT tblPeriods.PeriodNumber, tblLBCTransactions.ContractorID, Sum([StandardRate]*[ActualQuantities]) AS Amount, tblLBCTransactions.TransactionID, tblLBCTransactions.Print, tblLBCTransactions.DateIssued, tblRoads.RoadName, tblSections.Chainage, tblContractors.fName" & _

        " FROM tblPeriods INNER JOIN ((((tblRoads INNER JOIN tblSections ON tblRoads.RoadID = tblSections.RoadID) INNER JOIN (tblContractors INNER JOIN (tblLBCPackage INNER JOIN tblPackage_Contractor ON tblLBCPackage.PackageID = tblPackage_Contractor.PackageID) ON tblContractors.ContractorID = tblPackage_Contractor.ContractorID) ON tblSections.SectionID = tblLBCPackage.SectionID) INNER JOIN tblLBCTransactions ON (tblLBCPackage.PackageID = tblLBCTransactions.PackageID) AND (tblContractors.ContractorID = tblLBCTransactions.ContractorID)) INNER JOIN tblLBCTransactionsDetails ON tblLBCTransactions.TransactionID = tblLBCTransactionsDetails.TransactionID) ON tblPeriods.PeriodID = tblLBCTransactions.PeriodID " & _

        " GROUP BY tblPeriods.PeriodNumber, tblLBCTransactions.ContractorID, tblLBCTransactions.TransactionID, tblLBCTransactions.Print, tblLBCTransactions.DateIssued, tblRoads.RoadName, tblSections.Chainage, tblContractors.fName " & _

        " HAVING (((tblLBCTransactions.Print)=True));"

Debug.Print strSQL

On Error GoTo myErr

If Me.lstPeriod.ItemsSelected.Count = 0 Then

MsgBox " No Period selected", vbExclamation

Exit Sub

End If

Set db = CurrentDb()

Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)

If rst.EOF Then

MsgBox " No Contract Selected for Printing", vbInformation

Exit Sub

End If

rst.MoveFirst

rst.MoveLast

intCount = rst.RecordCount

strMsg = "Printing " & intCount & " Set of Employee Contracts"

strTemp = myFileName ' a private function which uses the File Dialog  for the user to select the template

If Len(strTemp) = 0 Then

MsgBox " No template selected", vbCritical

Exit Sub

End If

Set objWord = CreateObject("Word.Application")

Application.SysCmd acSysCmdInitMeter, strMsg, intCount

rst.MoveFirst

DoCmd.Hourglass True

Do While Not rst.EOF

        Set wrdDoc = objWord.Documents.Add(strTemp)

        objWord.Visible = False

        'Add information to the template

    With wrdDoc

        Set objRange = .Bookmarks("Name").Range

        objRange.Text = rst!fName

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Name", objRange

        Set objRange = .Bookmarks("Amount").Range

        objRange.Text = Format(Nz(rst!Amount, 0), "Currency")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Amount", objRange

        Set objRange = .Bookmarks("Amount1").Range

        objRange.Text = Format(Nz(rst!Amount, 0), "Currency")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Amount1", objRange

        Set objRange = .Bookmarks("Amount2").Range

        objRange.Text = Format(Nz(rst!Amount, 0), "Currency")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Amount2", objRange

        Set objRange = .Bookmarks("Amount3").Range

        objRange.Text = Format(Nz(rst!Amount, 0), "Currency")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Amount3", objRange

        Set objRange = .Bookmarks("AmountW").Range

        objRange.Text = English(Nz(rst!Amount, 0))

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "AmountW", objRange

        Set objRange = .Bookmarks("Cert").Range

        objRange.Text = rst!PeriodNumber

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Cert", objRange

        Set objRange = .Bookmarks("Date").Range

        objRange.Text = Format(Me.txtDate, "dd/mmmm/yyyy")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Date", objRange

        Set objRange = .Bookmarks("Date1").Range

        objRange.Text = Format(Me.txtDate, "dd/mmmm/yyyy")

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Date1", objRange

        Set objRange = .Bookmarks("Road").Range

        objRange.Text = rst!RoadName

        objRange.Font.Bold = True

        objRange.Font.Italic = True

        .Bookmarks.Add "Road", objRange

         strFilePath = CurrentProject.Path & "" & "Vouchers" & ""

                If Len(Dir(strFilePath, vbDirectory)) = 0 Then

                    MkDir strFilePath

                    End If

        strName = strFilePath & rst!fName & ".docx"

        .SaveAs (strName)

        .Close

End With

rst.MoveNext

Application.SysCmd acSysCmdUpdateMeter, intCount

Loop

rst.Close

'Exit Word

myExit:

Set objRange = Nothing

Application.SysCmd acSysCmdClearStatus

DoCmd.Hourglass False

Set rst = Nothing

Set wrdDoc = Nothing

objWord.Quit False

Set objWord = Nothing

Exit Sub

myErr:

MsgBox "Err" & err.Description

Resume myExit

End Sub

Thanks so much

Ronald

Answer 1

Hi Ronald,

Mailmerge is pretty easy, really. Your existing 'template' can provide the basic document, which yoy simply need to point to the data source, then insert mergefields where you now have bookmarks. Once you've done that, it's basically just a matter of finishing/executing the merge.

If you want to pursue the vba path, then using the code I posted, add a new variable:

wrdBigDoc As Word.Document

Then change the code between:

DoCmd.Hourglass True

and:

rst.Close

to:

'Create the output document

Set wrdBigDoc = objWord.Documents.Add(strTemp)

wrdBigDoc.Range.Delete

'Create a temporary document

Set wrdDoc = objWord.Documents.Add(strTemp)

objWord.Visible = False

Do While Not rst.EOF

With wrdDoc

Call UpdateBookmark(wrdDoc, "Name", rst!FName)

Call UpdateBookmark(wrdDoc, "Amount", Format(Nz(rst!Amount, 0), "Currency"))

Call UpdateBookmark(wrdDoc, "Amount1", Format(Nz(rst!Amount, 0), "Currency"))

Call UpdateBookmark(wrdDoc, "Amount2", Format(Nz(rst!Amount, 0), "Currency"))

Call UpdateBookmark(wrdDoc, "Amount3", Format(Nz(rst!Amount, 0), "Currency"))

Call UpdateBookmark(wrdDoc, "AmountW", English(Nz(rst!Amount, 0)))

Call UpdateBookmark(wrdDoc, "Cert", rst!PeriodNumber)

Call UpdateBookmark(wrdDoc, "Date", Format(Me.txtDate, "dd/mmmm/yyyy"))

Call UpdateBookmark(wrdDoc, "Date1", Format(Me.txtDate, "dd/mmmm/yyyy"))

Call UpdateBookmark(wrdDoc, "Road", rst!RoadName)

.Range.Copy

With wrdBigDoc

.Sections.Add

.Sections.Last.Range.Paste

End With

End With

rst.MoveNext

Application.SysCmd acSysCmdUpdateMeter, intCount

Loop

'Close the temporary document

wrdDoc.Close False

strFilePath = CurrentProject.Path & "" & "Vouchers" & ""

If Len(Dir(strFilePath, vbDirectory)) = 0 Then MkDir strFilePath

strName = strFilePath & "MailMergeOutput.docx"

'Save & close the output dopcument

With wrdBigDoc

.Sections.First.Range.Delete

.SaveAs (strName)

.Close

End With

I haven't tested the changes, but I think that's about all it should take. Note the changed name of the output document.

Answer 2

Hi,

Because your code works with specific bookmarks in your template, and only a single bookmark of a given name can exist in a document, the only way to have it generate a single document would be to have it open two documents, one of which is based on your existing template and, as each record is updated, copy that record to a new Section in the second document. At the end of the process, the document based on the current template could be discarded.

FWIW, your code can also be simplified:

Private Sub cmdCreate_Click()

Dim db As DAO.Database, rst As DAO.Recordset, strSQL As String, strFilePath As String, strName As String, strTemp As String

Dim icount As Integer, objWord As Word.Application, wrdDoc As Word.Document, objRange As Word.Range, intCount As Integer

Dim strMsg As String

strSQL = " SELECT tblPeriods.PeriodNumber, tblLBCTransactions.ContractorID, Sum([StandardRate]*[ActualQuantities]) AS Amount, tblLBCTransactions.TransactionID, tblLBCTransactions.Print, tblLBCTransactions.DateIssued, tblRoads.RoadName, tblSections.Chainage, tblContractors.fName" & _

        " FROM tblPeriods INNER JOIN ((((tblRoads INNER JOIN tblSections ON tblRoads.RoadID = tblSections.RoadID) INNER JOIN (tblContractors INNER JOIN (tblLBCPackage INNER JOIN tblPackage_Contractor ON tblLBCPackage.PackageID = tblPackage_Contractor.PackageID) ON tblContractors.ContractorID = tblPackage_Contractor.ContractorID) ON tblSections.SectionID = tblLBCPackage.SectionID) INNER JOIN tblLBCTransactions ON (tblLBCPackage.PackageID = tblLBCTransactions.PackageID) AND (tblContractors.ContractorID = tblLBCTransactions.ContractorID)) INNER JOIN tblLBCTransactionsDetails ON tblLBCTransactions.TransactionID = tblLBCTransactionsDetails.TransactionID) ON tblPeriods.PeriodID = tblLBCTransactions.PeriodID " & _

        " GROUP BY tblPeriods.PeriodNumber, tblLBCTransactions.ContractorID, tblLBCTransactions.TransactionID, tblLBCTransactions.Print, tblLBCTransactions.DateIssued, tblRoads.RoadName, tblSections.Chainage, tblContractors.fName " & _

        " HAVING (((tblLBCTransactions.Print)=True));"

Debug.Print strSQL

On Error GoTo myErr

If Me.lstPeriod.ItemsSelected.Count = 0 Then

  MsgBox " No Period selected", vbExclamation

  Exit Sub

End If

Set db = CurrentDb()

Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)

If rst.EOF Then

  MsgBox " No Contract Selected for Printing", vbInformation

  Exit Sub

End If

rst.MoveFirst

rst.MoveLast

intCount = rst.RecordCount

strMsg = "Printing " & intCount & " Set of Employee Contracts"

strTemp = myFileName ' a private function which uses the File Dialog  for the user to select the template

If Len(strTemp) = 0 Then

  MsgBox " No template selected", vbCritical

  Exit Sub

End If

Set objWord = CreateObject("Word.Application")

Application.SysCmd acSysCmdInitMeter, strMsg, intCount

rst.MoveFirst

DoCmd.Hourglass True

Do While Not rst.EOF

  'Add information to the template

  Set wrdDoc = objWord.Documents.Add(strTemp)

  objWord.Visible = False

  With wrdDoc

    Call UpdateBookmark(wrdDoc, "Name", rst!fName)

    Call UpdateBookmark(wrdDoc, "Amount", Format(Nz(rst!Amount, 0), "Currency"))

    Call UpdateBookmark(wrdDoc, "Amount1", Format(Nz(rst!Amount, 0), "Currency"))

    Call UpdateBookmark(wrdDoc, "Amount2", Format(Nz(rst!Amount, 0), "Currency"))

    Call UpdateBookmark(wrdDoc, "Amount3", Format(Nz(rst!Amount, 0), "Currency"))

    Call UpdateBookmark(wrdDoc, "AmountW", English(Nz(rst!Amount, 0)))

    Call UpdateBookmark(wrdDoc, "Cert", rst!PeriodNumber)

    Call UpdateBookmark(wrdDoc, "Date", Format(Me.txtDate, "dd/mmmm/yyyy"))

    Call UpdateBookmark(wrdDoc, "Date1", Format(Me.txtDate, "dd/mmmm/yyyy"))

    Call UpdateBookmark(wrdDoc, "Road", rst!RoadName)

    strFilePath = CurrentProject.Path & "" & "Vouchers" & ""

    If Len(Dir(strFilePath, vbDirectory)) = 0 Then

      MkDir strFilePath

    End If

    strName = strFilePath & rst!fName & ".docx"

    .SaveAs (strName)

    .Close

  End With

  rst.MoveNext

  Application.SysCmd acSysCmdUpdateMeter, intCount

Loop

rst.Close

'Exit Word

myExit:

Set objRange = Nothing

Application.SysCmd acSysCmdClearStatus

DoCmd.Hourglass False

Set rst = Nothing: Set wrdDoc = Nothing

objWord.Quit False

Set objWord = Nothing

Exit Sub

myErr:

MsgBox "Err" & Err.Description

Resume myExit

End Sub

Sub UpdateBookmark(oDoc As Word.Document, BmkNm As String, NewTxt As String)

Dim BmkRng As Range

With oDoc

  If .Bookmarks.Exists(BmkNm) Then

    Set BmkRng = .Bookmarks(BmkNm).Range

    With BmkRng

      .Text = NewTxt

      .Font.Bold = True

      .Font.Italic = True

    End If

    .Bookmarks.Add BmkNm, BmkRng

  End If

End With

Set BmkRng = Nothing

End Sub

Further simplications are also possible. If your template had cross-references to the 'Amount' and 'Date' bookmarks, the code to update the other bookmarks with the same data wouldn't be needed - all you'd need is a '.Fields.Update' command. By formatting the bookmarked ranges with the desired font, the '.Font.Bold = True' and '.Font.Italic = True' lines could also be deleted from the UpdateBookmark sub.

Edit: Added code to pass the oDoc reference to the UpdateBookmark sub.

Answer 3

I am a novice with Access, but I believe you can structure a query in Access that is then used by the Word mailmerge.

See the following article for more on using Access.

http://www.word.mvps.org/FAQs/MailMerge/CreateADataSource.htm

What I would suggest would be creating a primary merge document with the merge fields you want for each page. This would be set up as a letter merge and you would be creating a new document for editing. Once that primary document is created and saved, your Access code could actually open that template and perform the merge. I would not try to create or write the document itself from code; I'm not that ambitious and it is very easy to use an existing document.

Answer 4

Hello Charles

Thank you for the reply

I have never used a mail merge . I have  read the article in the link you provided.

I will give it a try.

I believe what i want to do  is more convenient if done from the Access DB.  I have a form  for easy selection of  Contractors , Dates,  and pay periods.

That why i want the process automated from access db

Ronald

Answer 5

Have you considered a Mail Merge from Word using your Access data?

Note that in Word jargon what you are talking about is not a template, but a document.