Private Sub PrintCustomReports()
'Created by Helen Feddema 17-Jan-2010
'Last modified 16-Mar-2010
On Error GoTo ErrorHandler
Dim strQuery As String
Dim strContactName As String
Dim strFileName As String
Dim strReport As String
Dim strCurrentPath As String
Dim strFileNameAndPath As String
Dim lngID As Long
Dim rpt As Access.Report
Dim rstContacts As DAO.Recordset
Dim strRecordSource As String
Dim strSQL As String
strRecordSource = "tblContacts"
Set dbs = CurrentDb
Set rstContacts = dbs.OpenRecordset("tblContacts")
strCurrentPath = Application.CurrentProject.Path & "\"
'This report has qrySingleContact as its record source
strReport = "rptContact"
strQuery = "qrySingleContact"
With rstContacts
Do While Not .EOF
lngID = ![ContactID]
strContactName = ![FirstName] & " " & ![LastName]
Debug.Print "Processing Contact ID " & lngID
strFileName = "Report for " & strContactName & ".pdf"
strFileNameAndPath = strCurrentPath & strFileName
Debug.Print "File name and path: " & strFileNameAndPath
'Create filtered query
strSQL = "SELECT * FROM " & strRecordSource & " WHERE " _
& "[ContactID] = " & lngID & ";"
Debug.Print "SQL for " & strQuery & ": " & strSQL
lngCount = CreateAndTestQuery(strQuery, strSQL)
Debug.Print "No. of items found: " & lngCount
If lngCount = 0 Then
GoTo NextContact
End If
'Print custom report
DoCmd.OpenReport ReportName:=strReport, View:=acViewDesign
Set rpt = Reports(strReport)
rpt.RecordSource = strSQL
DoCmd.OpenReport ReportName:=strReport, View:=acViewNormal
NextContact:
Loop
End With
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End Sub
|