merging several records into a single Word document

[hbaggs]

I am trying to merge multiple records into one Word document with the following code, however only the first record is merged into the single document....What do I need to add to my code below.
Many thanks

Sub ConstructStudentReport()
Dim objWRD As Word.Application
Dim objDoc As Word.Document

DoCmd.SetWarnings False
DoCmd.OpenQuery "qryIndividualStudentReport4"
DoCmd.SetWarnings True

Set objWRD = CreateObject("Word.Application")
objWRD.Visible = True
Set objDoc = objWRD.Documents.Add("c:\accessdocs\School Report4.dot", , , True)
objWRD.ScreenUpdating = False
objWRD.ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False




If DLookup("sex", "tblIndividualStudentReport4") = "Male" Then
objDoc.Bookmarks("bmkShe").Select
objWRD.Selection.Delete
End If

If DLookup("sex", "tblIndividualStudentReport4") = "Male" Then
objDoc.Bookmarks("bmkHer").Select
objWRD.Selection.Delete
End If

'''''''''''''''''''''''Now the more complicated
''''''''''''''''''''''''To find all instances of his and her delete them

objWRD.Visible = True
objWRD.ActiveDocument.MailMerge.Execute '<*******


objWRD.ScreenUpdating = True
DoCmd.Close
objWRD.ActiveDocument.Saved = True
objDoc.Close False '<************************
Set objDoc = Nothing
Set objWRD = Nothing
End Sub

 

[Premy]

You must set up a loop scheme for your recordset, something like:
Sub MyRecords()
Dim db as DAO.Database
Dim rs as DAO.Recordset
Dim strRecords as string

Set db = CurrentDb()
Set rs = db.OpenRecordset("qryIndividualStudentReport4", dbOpenDynaset)

'loop thru all the records
While Not rs.EOF
strRecords = strRecords & rs("Field1") & vbTab
strRecords = strRecords & rs("Field2") & vbTab
strRecords = strRecords & rs("Field3") & vbCrLf
rs.MoveNext
Wend
rs.Close
Set rs = Nothing

'Now you have all your records loaded in strRecords, so you can place them at any chosen bookmark in 'your template (dot) document:

InsertTextAtBookMark "Records", strRecords
end sub

Here u have the code for InsertTextAtBookMark:

Sub InsertTextAtBookMark(strBkmk As String, strText As String)
objDoc.Bookmarks(strBkmk).Select
objWord.Selection.Text = strText & ""
End Sub

You can also place the records in a table first for better layout, in that case the line:
InsertTextAtBookMark "Records", strRecords
becomes:
InsertItemsTable strRecords
So now u need the InsertItemsTable routine:

Sub InsertItemsTable(rsTbl As Recordset)
Dim strTable As String
Dim objTable As Word.Table
strTable = "Heading1" & vbTab & "Heading2" & vbTab & "Heading3" & vbCr
rsTbl.MoveFirst
While Not rsTbl.EOF
strTable = strTable & rsTbl("Field1") & vbTab & rsTbl("Field2") & vbTab & _
rsTbl("Field3") & vbCr
rsTbl.MoveNext
Wend
InsertTextAtBookMark "Records", strTable
Set objTable = objWord.Selection.ConvertToTable(Separator:=vbTab)
objTable.AutoFormat Format:=wdTableFormatClassic3, applyheadingrows:=True, AutoFit:=True, ApplyShading:=False
Set objTable = Nothing
End Sub

HTH
Premy

 

[hbaggs]

my amended code

thanks premy
I have used your code and placed it in mine where I needed it (or so I was thinking). It stops at the line
Set rs = db.OpenRecordset("qryIndividualStudentReport4", dbOpenDynaset)
Can you look over this code and tell me what is wrong?


Sub ConstructStudentReport()
Dim objWRD As Word.Application
Dim objDoc As Word.Document
' 3 New Lines
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strRecords As String

DoCmd.SetWarnings False
'DoCmd.OpenQuery "qryIndividualStudentReport4"

'2 new lines
Set db = CurrentDb()
Set rs = db.OpenRecordset("qryIndividualStudentReport4", dbOpenDynaset)
DoCmd.SetWarnings True
'loop thru all the records
While Not rs.EOF
strRecords = strRecords & rs("CommentsPara") & vbTab
'In this query there is only the one field in the record which contains the numerous items needed
'strRecords = strRecords & rs("Field2") & vbTab
'strRecords = strRecords & rs("Field3") & vbCrLf
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
Set objWRD = CreateObject("Word.Application")
objWRD.Visible = True
Set objDoc = objWRD.Documents.Add("c:\accessdocs\School Report4.dot", , , True)
objWRD.ScreenUpdating = False
objWRD.ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False

If DLookup("sex", "tblIndividualStudentReport4") = "Male" Then
objDoc.Bookmarks("bmkShe").Select
objWRD.Selection.Delete
End If

If DLookup("sex", "tblIndividualStudentReport4") = "Male" Then
objDoc.Bookmarks("bmkHer").Select
objWRD.Selection.Delete
End If

objWRD.Visible = True
objWRD.ActiveDocument.MailMerge.Execute '<*******
objWRD.ScreenUpdating = True
DoCmd.Close
objWRD.ActiveDocument.Saved = True
objDoc.Close False '<************************
Set objDoc = Nothing
Set objWRD = Nothing
End Sub

 

[Premy]

well, did u try stepping thru the code? U might try to put "rs.movefirst" just before "while not rs.eof" to force the loop to begin at the beginning of your recordset (just in case it doesn't automatically start at the beginning for some reason). u should also delete Setwarnings false (but first make sure it has been put to true) since u don't need it any longer and since it might yield some instructive err msg.

HTH
Premy