Why is my access report not being saved as a pdf document?

Question

I put a button on my report to output it to pdf but I keep getting error 2501 output was canceled. Below is the code I placed in a button on my form.

' Note Report opened from form button - cmdOpenRpt

Private sub cmdOpenRpt
Dim sRptName as string
    sRptName = Me.Name
    DoCmd.OpenReport sRptName, acViewPreview ' Report shows
    ' Note:Changed acViewPreview to acViewReport so I could click my button
End Sub   

Private Sub cmdSavePDF_Click()
Dim sRptName, sDateStamp, sTimeStamp, sFilename, sPath, sFilespec As String

    On Local Error GoTo ERR_cmdSavePDF_Click

    sRptName = Me.Name
    ' Create filename
    sTimeStamp = Format(Time, "hhmmss")
    sDateStamp = Format(Date, "yyyymmdd")
    sFilename = sRptName & "_" & sDateStamp & "_" & sTimeStamp & ".pdf"
    sPath = AppPath & "PDF\"
    'Public Function AppPath() As String
        'AppPath = Application.CurrentProject.Path & "\"
    'End Function
    sFilespec = sPath & sFilename
    DoCmd.OutputTo acOutputReport, sRptName, acFormatPDF, sFilespec, True

EXIT_cmdSavePDF_Click:
    Exit Sub
ERR_cmdSavePDF_Click:
    ShowError msRptName & "_cmdSavePDF_Click"
    Resume EXIT_cmdSavePDF_Click

End Sub
' Update: Was getting error:2501.  
' Now processing appears on the screen and then 
' execution jumps to exit sub (not to error handler) 
' no error code is displayed and the 
' report does not get saved as a 'pdf file' 
' I was hoping a pdf file would be made in my app path folder

Public Sub ShowError(WhereAt As String, Optional XtraMsg As String)
Dim sTitle, sDesc As String

    sTitle = "Error #" & CStr(Err) & " @ " & WhereAt
    sDesc = Err.Description & vbCrLf & "Source: " & Err.Source
    If Len(XtraMsg) > 0 Then sDesc = sDesc & vbCrLf & XtraMsg
    MsgBox sDesc, vbExclamation, sTitle
    
End Sub

Answer 1

My problem was that when I was converting the pages of my invoice report to pdf I failed to clear out the existing WHERE statement and they began piling up causing my code to crash. Here is the updated code that separates the pages of my invoice report so that individual pages can be created.

Private Sub MakePDFPages() Dim SQL, sWhere, sTimeStamp, sDateStamp, sFileName, sInvo, sCredit As String Dim i, j As Integer Dim lPos As Long

' All variables that have an m prefix are privately defined 
'in the declarations area of my form.
' Create individual pdfs
GetRptList
i = Len(msList)
j = 1
While j < i + 1
    ' Extract Invo & Credit from list
    lPos = InStr(j, msList, ";", vbBinaryCompare)
    sInvo = Mid(msList, j, lPos - j)
    j = lPos + 1
    lPos = InStr(j, msList, ";", vbBinaryCompare)
    sCredit = Mid(msList, j, lPos - j)
    j = lPos + 1
    ' Retrieve invoice report querydef SQL
    SQL = mdqRptQry.SQL
    ' Remove existing WHERE clause
    lPos = InStr(1, SQL, "WHERE")
    SQL = Left(SQL, lPos - 2)
    ' Create new WHERE clause from list
    sWhere = " WHERE (tblSales.SalesNumber=" & sInvo & ") AND (tblSales.CreditMemoNumber=" & sCredit & ");"
    ' Add new WHERE Clause to SQL
    SQL = SQL & sWhere
    ' Update querydef with new WHERE clause
    mdqRptQry.SQL = SQL
    ' Create filename
    sTimeStamp = Format(Time, "hhmmss")
    sDateStamp = Format(Date, "yyyymmdd")
    sFileName = msRptName & "_" & sDateStamp & "_" & sTimeStamp & ".pdf"
    ' Output report to pdf
    DoCmd.OutputTo acOutputReport, msRptName, acFormatPDF, sFileName
    DoCmd.Close acReport, msRptName
Wend

End Sub

Private Sub GetRptList() Dim qdRptQry As QueryDef Dim rs As Recordset

msList = vbNullString
Set qdRptQry = CurrentDb.QueryDefs(msQuery)
Set rs = qdRptQry.OpenRecordset(dbOpenForwardOnly)
If rs.RecordCount > 0 Then
    Do Until rs.EOF
        msList = msList & rs("SalesNumber") & ";" & rs("CreditMemoNumber") & ";"
        rs.MoveNext
    Loop
End If
rs.Close
Set rs = Nothing
Set qdRptQry = Nothing

End Sub

Answer 2

Code to first get a list of new invoices and then open each one separately to be saved as a pdf file. The default filename gets put in the clipboard so the user can paste it in. Then after clicking 'Save' a new pdf file is created. Execution should continue to open the next invoice (there are more then one Instead execution stops cold - not even in break mode. Then when I go to the new pdf file and open it I get the message that the file is corrupt. Yet, the report opens fine when I open it from the database window in rptview. Report opens when using acViePreview. Right after the DoCmd.Output statement execution jumps out of Where-Wend structure and goes to the line just below Wend (Exit Sub) and code is now in break mode.

Private Sub cmdPDF_Click()
Dim rs As Recordset
Dim SQL, sInvo, sCredit, sPath, sWhere, sMsg, sTitle As String
Dim sTimeStamp, sDateStamp, sFileName As String
Dim iFrame As Integer
Dim lPos, i, j As Long

    On Local Error GoTo EXIT_cmdPDF_Click
    
    sPath = AppPath & "PDFs\"
    ChDir sPath
    sTitle = "Click ok to open next report"
    sMsg = "Paste filename from clipboard. before saving report to pdf." & vbCrLf & _
    "Saving report as PDF to folder: " & sPath
    ' Retrieve all invoices that haven't been saved to pdf file
    ' Add WHERE clause to report query - WHERE (SalesIsPrinted=False)
    If Not UpdateReportQry Then GoTo EXIT_cmdPDF_Click:
    If msRptName = "rptInvoCredit" Then
        ' Create individual pdfs
        GetRptList
        i = Len(msList)
        j = 1
        While j < i + 1
            lPos = InStr(j, msList, ";", vbBinaryCompare)
            sInvo = Mid(msList, j, lPos - j)
            j = lPos + 1
            lPos = InStr(j, msList, ";", vbBinaryCompare)
            sCredit = Mid(msList, j, lPos - j)
            j = lPos + 1
            ' Create report filter
            sWhere = "(SalesNumber=" & sInvo & ") AND (CreditMemoNumber=" & sCredit & ");"
            ' Create filename
            sTimeStamp = Format(Time, "hhmmss")
            sDateStamp = Format(Date, "yyyymmdd")
            sFileName = msRptName & "_" & sDateStamp & "_" & sTimeStamp & ".pdf"
            CopyTextToClipboard sFileName
            ' Open report
            DoCmd.OpenReport msRptName, acViewNormal, , sWhere, acWindowNormal
            MsgBox sMsg, vbInformation, sTitle
            ' DoCmd.OutputTo does nothing
            'DoCmd.OutputTo acOutputReport, msRptName, acFormatPDF, sFileSpec, True
            'DoCmd.Close acReport, msRptName
        Wend
    End If
    ' Filename can now be pasted in then click save

EXIT_cmdPDF_Click:
    Exit Sub
ERR_cmdPDF_Click:
    ShowError "frmInvoiceReport_cmdPDF_Click"
    Resume EXIT_cmdPDF_Click
    
End Sub

Private Sub GetRptList()
Dim qdRptQry As QueryDef
Dim rs As Recordset
Dim SQL As String

    ' Retrieve invoice report querydef SQL
    SQL = mqdReport.SQL
    ' Remove existing WHERE clause - WHERE (SalesIsPrinted=False)
    lPos = InStr(1, SQL, "WHERE")
    SQL = Left(SQL, lPos - 1)
    ' Update query without the where clause
    mqdReport.SQL = SQL
    
    msList = vbNullString
    Set qdRptQry = CurrentDb.QueryDefs(msRptQuery)
    Set rs = qdRptQry.OpenRecordset(dbOpenForwardOnly)
    If rs.RecordCount > 0 Then
        Do Until rs.EOF
            msList = msList & rs("SalesNumber") & ";" & rs("CreditMemoNumber") & ";"
            rs.MoveNext
        Loop
    End If
    rs.Close
    Set rs = Nothing
    Set qdRptQry = Nothing

End Sub

Public Sub CopyTextToClipboard(ByVal TextIn As String)
Const ksClipObj As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
Dim objClipboard As Object

    ' Save text to clipboard
    Set objClipboard = CreateObject(ksClipObj)
    objClipboard.SetText TextIn
    objClipboard.PutInClipboard
    Set objClipboard = Nothing