Test Write Access to Backend Path (1 Viewer)

Status
Not open for further replies.

speakers_86

Registered User.
Local time
Today, 03:22
Joined
May 17, 2007
Messages
1,919
This will test all backend path locations for write access. If write access is denied or the medium is unplugged, there will be an error. It does not in any way relink tables. This is intended to be done before checking the table links, just to make sure the permissions are correct. If the path cannot be written to, you may exit gracefully.

Code:
Option Compare Database
Option Explicit

Public Function BackendPathsAvailable(Optional booErrorOnAllBrokenLinks As Boolean = True) As Boolean
    On Error GoTo err

    Dim strPath As String
    Dim booResult As Boolean
    
    booResult = True
    
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("SELECT MSysObjects.Database FROM MSysObjects GROUP BY MSysObjects.Database HAVING (((MSysObjects.Database) Is Not Null)); ")
    
    If rst.RecordCount <> 0 Then
        rst.MoveFirst
        While Not rst.EOF
            strPath = Left(rst!Database, Len(rst!Database) - Len(GetFilenameFromPath(rst!Database)))
            If TestPath(strPath, booErrorOnAllBrokenLinks) = False Then booResult = False
            rst.MoveNext
        Wend
    End If
    
    rst.Close
    Set rst = Nothing
    
    BackendPathsAvailable = booResult

    Exit Function
err:
    Debug.Print err.Description
End Function


Private Function TestPath(strPath As String, booError As Boolean) As Boolean
    On Error GoTo err
    
    Dim fso As Object
    Dim obj As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set obj = fso.CreateTextFile(strPath & "\path testing delete me.txt", True)
    obj.WriteLine ("This file is only a test.  It can be deleted safely.")
    obj.Close
    
    TestPath = True
    TryDeleteFile strPath
    Exit Function
err:
    If booError Then MsgBox "There was an error finding the following path: " & vbCrLf & strPath & vbCrLf & vbCrLf & err.Number & ": " & err.Description
End Function

Private Sub TryDeleteFile(strPath As String)
    On Error Resume Next
    Kill strPath & "\path testing delete me.txt"
End Sub


Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'

    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function
 
Status
Not open for further replies.

Users who are viewing this thread

Top Bottom