Private Sub cmdPDF_Click()
Dim rs As Recordset
Dim SQL, sInvo, sCredit, sPath As String
Dim sTimeStamp, sDateStamp, sFileName, sFileSpec As String
Dim lPos, i, j As Long
On Local Error GoTo EXIT_cmdPDF_Click
' Retrieve all invoices that haven't been saved to pdf file - WHERE (SalesIsPrinted=False)
' Open report - msRptName is a private variable that holds the access report name (m=Modular, s=String)
DoCmd.OpenReport msRptName, acViewPreview ' Report shows
Me.TimerInterval = 2000 ' Give report two seconds to be displayed
sPath = AppPath & "PDF\"
'Public Function AppPath() As String
'AppPath = Application.CurrentProject.Path & "\"
'End Function
' Add WHERE clause to report query
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 - 1)
j = lPos + 1
lPos = InStr(j, msList, ";", vbBinaryCompare)
sCredit = Mid(msList, j, lPos - j)
' Retrieve querydef SQL and modify it so it only shows a single record
SQL = mqdReport.SQL
' Remove existing WHERE clause - WHERE (SalesIsPrinted=False)
lPos = InStr(1, SQL, "WHERE")
SQL = Left(SQL, lPos - 1)
' Replace WHERE clause created from list
SQL = SQL & "WHERE (SalesNumber=" & sInvo & ") AND (CreditMemoNumber=" & sCredit & ");"
' Update query
mqdReport.SQL = SQL
' Create filename
sTimeStamp = Format(Time, "hhmmss")
sDateStamp = Format(Date, "yyyymmdd")
sFileName = msRptName & "_" & sDateStamp & "_" & sTimeStamp & ".pdf"
sFileSpec = sPath & sFileName
' Create PDF file
DoCmd.OutputTo acOutputReport, msRptName, acFormatPDF, sFileSpec, True
DoCmd.Close acReport, msRptName
Wend
End If
' Processing is visible on screen then execution jumps to Exit Sub
' (It doesn't even get to the close report statement)
' No pdf file gets created and no errors are shown
' All I want is to export an access report to a pdf file. Hope someone can help me
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
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