How do I print Access report to PDF, give PDF unique name based on report content, and save it to a special folder on my computer?

    Declare Function nWritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyname As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
 
Sub PrintToPDF(r As Report, fn As String)
    Const PROC_LOC = 9192
    On Error GoTo proc_err
    Dim sPDFINI As String
    Dim s As String
    Dim i As Integer
    Dim t0 As Long
    Dim stg As String
    
    stg = "Getting location of INI file"
    
    sPDFINI = "c:\pdf995\res\pdf995.ini"
        
    stg = "Setting Printer for report " & r.Name
    
    r.Printer = Printers("PDF995")
 
    nWritePP fn, sPDFINI, "Parameters", "Output File"
 
    stg = "Opening report " & r.Name
    
    Screen.MousePointer = 11
    DoCmd.OpenReport r.Name, acViewNormal
    
    t0 = Timer
    
    stg = "Waiting for report to print "
    
    For i = 1 To 10
        DoEvents
    Next
    
    For i = 1 To 10
        If Len(fn) > 0 And Len(Dir(fn)) > 0 Then
            Exit For
        End If
        If Timer - t0 > 10000 Then
            If vbYes = MsgBox("PDF " & fn & " not created yet, continue waiting?", vbYesNo) Then
                t0 = Timer
            Else
                Exit For
            End If
        End If
        DoEvents
    Next
    
    stg = "Finished waiting for report to print to " & fn
    
    i = MsgBox("PDF " & fn & " created: do you want to view it?", vbYesNo)
    If i = vbYes Then
        ShellExecute 0, "open", fn, "", "", vbNormalFocus
    Else
    End If
    
    stg = "Resetting INI file"
 
 
proc_exit: 'Single exit point
    stg = "Exiting"
    Screen.MousePointer = 0
    Exit Sub
proc_err: 'Error trapping
    If Err = 5 And stg Like "Setting Printer*" Then
        'Your cases here
        MsgBox "Couldn't set printer to PDF995. Is PDF995 installed on this workstation?" & stg
        GoTo proc_exit
    Else
    End If
msgbox error
resume proc_exit
End Sub
 
Function nWritePP(ByVal Value As String, ByVal AppName As String, ByVal Section As String, ByVal Key As String) As Integer
On Error GoTo nWritePP_Err
 
    If UCase$(AppName) Like "*.?*" Then
    Else
        AppName = AppName & ".ini"
    End If
    
    nWritePP = nWritePrivateProfileString(Section, Key, Value, AppName)
 
nWritePP_Exit:
    Exit Function
    
nWritePP_Err:
    MsgBox "Error: " + Error$, 0, "nWritePP"
    Resume nWritePP_Exit
 
End Function

Select allOpen in new window