speakers_86
Registered User.
- Local time
- Yesterday, 20:45
- 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