printing report to PDF based on each record in query - vba

Question

I have a query in Access (Q_Invoices) that has separate records based on the invoice number (Invoice_Number). I also have a report that is linking to this query (R_Invoices_PDF). What I would like to do is to have VBA code to loop through each record in the query, and print the record as a separate PDF from the report.
I copied the following code from some website, and tried to adapt it for my purposes. It works to an extent. However, I stop it before it loops, and it saves all the records, not just the first one.
Private Sub cmd_GenPDFs_Click()
Dim rs As DAO.Recordset
Dim sFolder As String
Dim sFile As String
On Error GoTo Error_Handler
sFolder = "D:\Documents\Orchestra\Invoices\Invoice files\"
Set rs = CurrentDb.OpenRecordset("SELECT Invoice_Number FROM Q_Invoices", dbOpenSnapshot)
With rs
.MoveFirst
Do While Not .EOF
DoCmd.OpenReport "R_Invoices_PDF", acViewPreview, , "[Invoice_Number]=" & ![Invoice_Number], acHidden
sFile = Nz(![Invoice_Number], "") & ".pdf"
sFile = sFolder & sFile
DoCmd.OutputTo acOutputReport, "R_Invoices_PDF", acFormatPDF, sFile, acExportQualityPrint
'If you wanted to create an e-mail and include an individual report, you would do so now
DoCmd.Close acReport, "R_Invoices_PDF"
.MoveNext
Loop
End With
Application.FollowHyperlink sFolder 'Optional / Open the folder housing the files
Error_Handler_Exit:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then 'Let's ignore user cancellation of this action!
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: cmd_GenPDFs_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Sub

Answer 1

I recall some issue with filtering the report. Thus, we filter the query that drives the report to return only data for a single invoice using a TempVars.
Here, Faktura means Invoice:
Private Sub FakturaPrint( _
ByVal PrintType As CdPrintType, _
Optional ByRef FullPath As String)
Const ReportName As String = "Faktura"
Const FileNameMask As String = "Faktura{0}.pdf"
Const FileIdMask As String = "kladde Job {0}"
Const CancelError As Long = 2212 ' Cactus TimeSag cannot print the object.
Const PrintError As Long = 2501 ' PrintOut was cancelled.
Dim Path As String
Dim FileName As String
Dim FileId As String
Dim PrintCount As Integer
Dim PrintCopy As Integer
On Error GoTo FakturaPrint_Click_Error
' Set filter on the source query of the report.
TempVars("FakturaID").Value = Me!FaktID.Value
Select Case PrintType
Case cdPrintPreview
DoCmd.OpenReport ReportName, acViewPreview, , , acWindowNormal
Case cdPrintPrinter
PrintCount = Nz(Me!UdskFakt.Column(2), 1)
If PrintCount < 1 Then
PrintCount = 1
End If
For PrintCopy = 1 To PrintCount
DoCmd.OpenReport ReportName, acViewNormal, , , acWindowNormal
Next
Case cdPrintPdf
Path = Environ("USERPROFILE") & "\Documents\"
FileId = Nz(Str(Me!Faktura.Value), Replace(FileIdMask, "{0}", Me!JobID.Value))
FileName = Replace(FileNameMask, "{0}", FileId)
' Return FullPath by reference for e-mail.
FullPath = Path & FileName
DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF, FullPath, False, , , acExportQualityPrint
End Select
FakturaPrint_Click_Exit:
Me!TextForClipboard.SetFocus
Exit Sub
FakturaPrint_Click_Error:
Select Case Err.Number
Case CancelError, PrintError
' Printing cancelled by user.
' Ignore.
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FakturaPrint_Click of Sub Form_Faktura"
End Select
Resume FakturaPrint_Click_Exit
End Sub
It is not a loop, but you can probably easily abstract from that.