根据查询中的每条记录将报告打印为 PDF

Question

我在 Access (Q_Invoices) 中有一个查询，该查询具有基于发票编号 (Invoice_Number) 的单独记录。我还有一份链接到此查询的报告 (R_Invoices_PDF)。我想做的是让 VBA 代码遍历查询中的每条记录，并将记录打印为报告中的单独 PDF。

我从某个网站复制了以下代码，并尝试根据我的目的对其进行调整。它在一定程度上起作用。但是，我在它循环之前停止它，它会保存所有记录，而不仅仅是第一个。

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

我记得过滤报告的一些问题。因此，我们使用TempVars 过滤驱动报告以仅返回单个发票数据的查询。

这里，Faktura 表示发票：

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

这不是一个循环，但您可能很容易从中抽象出来。