Manipulating MS Word Documents from MS Access 2003

The following code generates separate word documents for each parent record in a table called T001ParentRecords and places the children records relating to the parent record in a word document. It then goes on to format that word document before saving and closing and then moving to the next document and starting the process again.

As such it takes the code relating to looping through recordsets and also the code relating to generating word documents and combines the two. This could be very good for automatically generating whole host of different things.

It uses the WEND statement rather than the Do Until Loop as I was told it was better practice.

Function AutoGenerateParentChildWordDocuments()

'Make sure the name of the recordset is unambigous
'Good practice to reference the actual library
'Please ensure that you go to Tools - Refererences and select Microsoft Word 11 0 Object Library

Dim rs As DAO.Recordset
Dim db As DAO.Database

Dim rschild As DAO.Recordset

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set db = CurrentDb
'Place your SQL for parent records to be created
Set rs = db.OpenRecordset("SELECT * FROM T001ParentRecords")

If Not (rs.EOF And rs.BOF) Then
'There are no records if EOF and BOF are both true you are at the end and at the beginning

rs.MoveLast
rs.MoveFirst
While (Not rs.EOF)
Set wrdApp = CreateObject("Word.Application")

'Create the new document
Set wrdDoc = wrdApp.Documents.Add
'The following line can be altered to open the document on the screen
wrdApp.Visible = False
'Next setup the margins of the document
wrdDoc.PageSetup.LeftMargin = CentimetersToPoints(1.27)
wrdDoc.PageSetup.RightMargin = CentimetersToPoints(1.27)
wrdDoc.PageSetup.TopMargin = CentimetersToPoints(1.27)
wrdDoc.PageSetup.BottomMargin = CentimetersToPoints(1.27)

With wrdDoc

.Styles(wdStyleHeading1).Font.Name = "Algerian"
.Styles(wdStyleHeading1).Font.Size = 14
.Styles(wdStyleHeading1).Font.Bold = True
.Styles(wdStyleHeading1).Font.Color = wdColorBlack

.Styles(wdStyleHeading3).Font.Name = "Courier"
.Styles(wdStyleHeading3).Font.Size = 12
.Styles(wdStyleHeading3).Font.Bold = False
.Styles(wdStyleHeading3).Font.Color = wdColorBlack
.Styles(wdStyleHeading3).NoSpaceBetweenParagraphsOfSameStyle = True
.Styles(wdStyleHeading3).ParagraphFormat.Alignment = wdAlignParagraphJustify

.Styles(wdStyleHeading2).Font.Name = "Arial"
.Styles(wdStyleHeading2).Font.Size = 12
.Styles(wdStyleHeading2).Font.Bold = True
.Styles(wdStyleHeading2).Font.Color = wdColorRed
.Styles(wdStyleHeading2).NoSpaceBetweenParagraphsOfSameStyle = True
.Styles(wdStyleHeading2).ParagraphFormat.Alignment = wdAlignParagraphJustify

.Styles(wdStyleNormal).Font.Name = "Arial"
.Styles(wdStyleNormal).Font.Size = 10
.Styles(wdStyleNormal).Font.Color = wdColorBlue

'Better to set style before insert
.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading1)
.Content.InsertAfter ("Sitename:" & rs!Sitename)
.Content.InsertParagraphAfter

.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading3)
.Content.InsertAfter ("Town:" & rs!Town)
.Content.InsertParagraphAfter

.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading3)
.Content.InsertAfter ("Postcode:" & rs!Postcode)
.Content.InsertParagraphAfter

Set rschild = db.OpenRecordset("SELECT * FROM T002ChildRecords WHERE FKID = " & rs!PKID)

If Not (rschild.EOF And rschild.BOF) Then
'There are no records if EOF and BOF are both true you are at the end and at the beginning

rschild.MoveLast
rschild.MoveFirst

While (Not rschild.EOF)

'Again better to set style before insert
.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading1)
.Content.InsertAfter ("Consulting Body:" & rschild!Body)

.Content.InsertParagraphAfter
.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleHeading2)
.Content.InsertAfter ("Consultation response : " & rschild!Comment)
.Content.InsertParagraphAfter

.Content.InsertParagraphAfter
.Paragraphs(.Paragraphs.Count).Style = .Styles(wdStyleNormal)
.Content.InsertAfter ("Consultation Date: " & rschild!DateUpdated)
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter

rschild.MoveNext
Wend
Else
End If

rschild.Close

.SaveAs ("c:\temp\Auto-Generated-WordDoc-" & rs!Town & rs!PKID & ".doc")
.Close ' close the document

End With ' With wrdDoc
Set wrdDoc = Nothing

wrdApp.Quit ' close the Word application
Set wrdApp = Nothing

rs.Edit
rs.Update
rs.MoveNext

Wend

rs.Close
Else
MsgBox "No Records Available for updating exit sub"
Exit Function
End If

MsgBox "Looped through the records and updated the value number field"

Set rschild = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Download an example database HERE

Boilerplate code demonstrating simple Recordset manipulation

About Mark

Mark Brooks a forty something individual working and living in and around Edinburgh
This entry was posted in All, VBA Code MS Access. Bookmark the permalink.