how to cope with error 2501 (1 Viewer)

[rehanemis]

Hi all,
My access program printing the reports in pdf on local drive well. But when computer on network then some time it saves the pdf on desktop but most of the time the error occurs which is 2501.

Private Sub cmdPrint_Click()
Me.Form.Refresh
' my code
DoCmd.SetWarnings False
Dim strUserName As String
Dim strPath As String
Dim strDate As Date
Dim db_report_name  As String
Dim strFileName As String

Me.cboSearch.SetFocus
If (IsNull(Me.cboSearch.Text) Or Me.cboSearch.Text = "") Then
   ' MsgBox "Please select EMP ID from drop down", vbInformation, "Tool Admin"
    
        DoCmd.OpenForm "frmMessage"
        Form_frmMessage.lblMessage.Caption = "EMP ID is missing ! Please select EMP ID from drop down"
Exit Sub
End If
db_report_name = DLookup("fldReportName", "tbl_ReportNames", "Full_Name = '" & Me.cmbAllReports.value & "'")
db_report_name = Replace(db_report_name, " ", "")

strFileName = Me.EmpID & "_" & Me.FirstName & "_" & Me.cmbAllReports
'strFileName = "Consent Form"
 strUserName = Environ("username")
 
 If Len(strFileName) = 0 Then
 Else
 
strPath = "C:\Users\" & strUserName & "\desktop\rpts\" & strFileName & " .pdf"
'DoCmd.OpenReport "rptConsentForm", acViewPreview

DoCmd.OutputTo acOutputReport, db_report_name, acFormatPDF, strPath, False
End If

'my code end
DoCmd.SetWarnings True
End Sub

Can any body suggest or having experience of similar problem and handled it?

 

[pbaldy]

I'd guess your path doesn't exist. Does every user have the rpts folder on their desktop?

FYI I moved your thread out of the code repository.

 

[bastanu]

I have been using this code to get the user folders (add in a new standard module):

Option Compare Database
Option Explicit


#If VBA7 And Win64 Then
    'x64 Declarations
   Public Declare PtrSafe Function SHGetSpecialFolderLocation _
        Lib "shell32" (ByVal hwnd As Long, _
        ByVal nFolder As Long, ppidl As Long) As Long

    Public Declare PtrSafe Function SHGetPathFromIDList _
        Lib "shell32" Alias "SHGetPathFromIDListA" _
        (ByVal pidl As Long, ByVal pszPath As String) As Long

    Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
#Else
    'x32 Declaration
    Public Declare Function SHGetSpecialFolderLocation _
        Lib "shell32" (ByVal hwnd As Long, _
        ByVal nFolder As Long, ppidl As Long) As Long

    Public Declare Function SHGetPathFromIDList _
        Lib "shell32" Alias "SHGetPathFromIDListA" _
        (ByVal pidl As Long, ByVal pszPath As String) As Long

    Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

#End If

Public Const FOLD_PERSONAL = &H5
Public Const FOLD_DESKTOP = &H10
Public Const MAX_PATH = 260
Public Const NOERROR = 0

Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
    lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
    If lngFolderFound Then
        SpecFolder = Left$(strPath, _
            InStr(1, strPath, vbNullChar) - 1)
    End If
End If
CoTaskMemFree lngPidl
End Function

You can then check if the rpts folder exists and if not create it then export the file.

Cheers,