I use code below to create reports.
Now I get error 2501, after restarting my computer it is working again.
When I have this error I can change code below to output snp, or html and it works fine.
So this error only appears when exporting to pdf.
Does anybody has a working solution for this problem?
Now I get error 2501, after restarting my computer it is working again.
When I have this error I can change code below to output snp, or html and it works fine.
So this error only appears when exporting to pdf.
Does anybody has a working solution for this problem?
Code:
Option Compare Database
Option Explicit
Const sDefaultPath As String = "C:\Temp\"
Dim rs As DAO.Recordset
Dim str1SQL As String
Dim str2SQL As String
Dim strRptName As String
Dim rpt As Report
Dim strDBName As String
Dim strDBPath As String
Dim strFunctionName As String
Dim strModuleName As String
Dim strDescription As String
Dim Fldr As String
Dim strErrorNumber As Long
Public Function MyMkDir(sDefaultPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim I As Integer
If sDefaultPath <> "" Then
aDirs = Split(sDefaultPath, "\")
If Left(sDefaultPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sDefaultPath, InStr(iStart, sDefaultPath, "\"))
For I = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(I) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next I
End If
End Function
Function ExportReportsPDF()
'DoCmd.Echo False 'suppress the screen updates = ON
On Error GoTo errHandler
If Len(Dir(sDefaultPath, vbDirectory)) = 0 Then
MyMkDir sDefaultPath
End If
strDBName = Application.CurrentProject.Name
strDBPath = Application.CurrentProject.Path
strFunctionName = "ExportReportsPDF"
str1SQL = "SELECT [MSysObjects]![Name] AS Report " & _
"FROM MSysObjects " & _
"WHERE (((MSysObjects.Name) Like ""exp*"") And ((MSysObjects.Type) = -32764))"
Set rs = DBEngine(0)(0).OpenRecordset(str1SQL)
Do While Not rs.EOF
Debug.Print rs!Report
strRptName = rs!Report
DoCmd.OpenReport strRptName, acViewDesign
Set rpt = Reports(strRptName)
rpt.Printer.PaperSize = acPRPSA4
DoCmd.Save
DoCmd.Close acReport, strRptName, acSaveNo
DoCmd.OutputTo acOutputReport, strRptName, acFormatPDF, sDefaultPath & Mid(rs!Report, 4, 55) & ".pdf", False, "", 0, acExportQualityPrint
ExportError:
rs.MoveNext
Loop
Exit Function
errHandler:
strDescription = Chr(34) & Err.Description & Chr(34)
strErrorNumber = Err.Number
Select Case strErrorNumber
Case 29068
Resume Next
Case 3314, 2101, 2115 ' Can't save.
Resume Next
Case Else
'str2SQL = "INSERT INTO tblErrorLog (ErrDate, ExportName, ErrFunction, ErrNumber, ErrDatabase, ErrPath, ErrDescription, ErrModule) VALUES(#" & Format(Now(), "yyyy-mm-dd hh:mm:ss") & "#, '" & strRptName _
'& "', '" & strFunctionName & "', " & strErrorNumber & ", '" & strDBName & "' , '" & strDBPath & "' ," & strDescription & ", '" & VBE.ActiveCodePane.CodeModule & "');"
'DoCmd.RunSQL str2SQL
MsgBox "Error: ( " & Err.Number & " ) " & Err.Description, vbCritical
End Select
Resume ExportError
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
'DoCmd.Echo False 'suppress the screen updates = Off
End Function
Last edited: