'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

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