Loop thru a Recordset and Output To seperate .RTF or .PDF...
The difficult I do immediately, the impossible takes a little bit longer.
'Posted by ADezii 5.23.2009 on bytes.com
'Modified by Gina Whipp 11.4.2009 to OutputTo Multiple Files
'Tested in Access 2003 and Access 2010 with a Combo Box
 
Dim intCounter As Integer 
Dim cboCode As ComboBox
 
Set cboCode = Me![YourControl]
 
'If Your Data Type is Numeric use this section
For intCounter = 0 To cboCode.ListCount - 1
DoCmd.OpenReport "YourReport", acViewPreview, , _
"[YourFieldControlSource] = " & cboCode.ItemData(intCounter) 
DoEvents
DoCmd.OutputTo acOutputReport, "YourReport", acFormatRTF, "DriveLetter:/FolderName/FileName" & Format(intCounter, "000") & ".rtf"
'DoCmd.OutputTo acOutputReport, "YourReport", acFormatPDF, "DriveLetter:/FolderName/FileName" & Format(intCounter, "000") & ".pdf"
DoCmd.Close acReport, "YourReport"
Next
 
 
'If Your Data Type is a String use this section
For intCounter = 0 To cboCode.ListCount - 1
DoCmd.OpenReport "YourReport", acViewPreview, , _
"[YourFieldControlSource] = '" & cboCode.ItemData(intCounter) & "'" 
DoEvents
DoCmd.OutputTo acReport, "YourReport", acFormatRTF, "DriveLetter:/FolderName/FileName" & Format(intCounter, "000") & ".rtf"
'DoCmd.OutputTo acOutputReport, "YourReport", acFormatPDF, "DriveLetter:/FolderName/FileName" & Format(intCounter, "000") & ".pdf"
DoCmd.Close acReport, "YourReport"
Next
VBA
Tips (Main)
Home
Creating a Multi-Value field using Alphabet
Copy Fields Down from above Record
Modified Spell Check
Code Snippets
Lock\Unlock Bound Controls
Loop while renumbering two columns
Create a Table with Dynamic Field Names
Snippets for Exporting to Excel
Log Field Changes
Log Record Deletions
Check for Duplicate Values
ValidateData()
ClearClipboard()
Selecting an Excel Worksheet from Access
Send eMail to Multiple Recipients
Cancel Save in a Bound Form
Automatically Send eMail Notifications
fFindBookmark()
Looping Records to Send eMail
fxlFindReplace()
fMouseOverCurrent()
fHighlightRequiredControls()
Check if Table Exists
fAmortization()
Insert (or Remove) Blank Line
Click to send feedback...
Function fSaveReportsAsPDF() As String
On Error GoTo Error_Proc
'From https://www.access-diva.com/
 
    DoCmd.Hourglass True
 
    Dim strSQL As String
    Dim rs As Recordset
    Dim strPath As String
 
    strPath = "YourDrive:\YourPath\"
    strSQL = "SELECT UniqueField" & _
                "FROM tblYourTable"
 
    Set rs = CurrentDb.OpenRecordset(strSQL)
 
    With rs
        .MoveFirst
            Do While Not .EOF
                DoCmd.OpenReport "rptYourReport", acViewPreview, , "[UniqueField] = '" & rs!UniqueField & "'"
                DoCmd.Minimize
                DoCmd.OutputTo acOutputReport, "rptYourReport", acFormatPDF, strPath & !UniqueField & ".pdf"
                DoCmd.Close acReport, "rptYourReport", acSaveNo
 
        .MoveNext
        Loop
    End With
 
    rs.Close
    Set rs = Nothing
 
Exit_Proc:
    DoCmd.Hourglass False
    Exit Function
Error_Proc:
    Select Case Err.Number
        Case 287:
          Resume Exit_Proc 'ignore the error
        Case Else:
          MsgBox "Error encountered fSaveReports: " & Err.Description, vbExclamation, Err.Number
          Resume Exit_Proc 'display a message then exit
    End Select
 
End Function
With Combo Box or List Box
fSaveReportsAsPDFs
Be sure to change the strSQL, Fields, Controls, Paths and Reports to match your own!
This site uses cookies to collect data on usage. By continuing to browse this site you consent to this policy. Find out more here.