Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Fix555 verify path #557

Open
wants to merge 5 commits into
base: dev
Choose a base branch
from
Open

Fix555 verify path #557

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
994763b
Update FSO to try a second time and update error handling. #555
hecon5 Oct 24, 2024
8b5d50c
Refactor VerifyPath to catch errors and gracefully bail out if the pa…
hecon5 Oct 24, 2024
d693cfc
Because VerifyPath does the same function as MkDirIfNotExist, this is…
hecon5 Oct 24, 2024
18e33ca
Update UNC Path handling with error logging and handling. #555
hecon5 Oct 24, 2024
0b7355d
Move file based functions to `modFileAccess`.
hecon5 Oct 25, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
223 changes: 140 additions & 83 deletions Version Control.accda.src/modules/modFileAccess.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,10 @@ Private Declare PtrSafe Function getTempFileName Lib "kernel32" Alias "GetTempFi
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long

Private Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExW" ( _
ByVal hwnd As LongPtr _
, ByVal pszPath As LongPtr _
, ByVal psa As Any) As Long

'---------------------------------------------------------------------------------------
' Procedure : GetTempFile
Expand Down Expand Up @@ -213,22 +217,6 @@ Public Sub DeleteFile(strFile As String, Optional blnForce As Boolean = True)
End Sub


'---------------------------------------------------------------------------------------
' Procedure : MkDirIfNotExist
' Author : Adam Waller
' Date : 1/25/2019
' Purpose : Create folder `Path`. Silently do nothing if it already exists.
'---------------------------------------------------------------------------------------
'
Public Sub MkDirIfNotExist(strPath As String)
If Not FSO.FolderExists(StripSlash(strPath)) Then
Perf.OperationStart "Create Folder"
FSO.CreateFolder StripSlash(strPath)
Perf.OperationEnd
End If
End Sub


'---------------------------------------------------------------------------------------
' Procedure : MoveFileIfExists
' Author : Adam Waller
Expand All @@ -241,7 +229,7 @@ Public Sub MoveFileIfExists(strFilePath As String, strToFolder As String)
Dim strNewPath As String
If FSO.FileExists(strFilePath) Then
Perf.OperationStart "Move File"
MkDirIfNotExist strToFolder
VerifyPath strToFolder
strNewPath = StripSlash(strToFolder) & PathSep & FSO.GetFileName(strFilePath)
If FSO.FileExists(strNewPath) Then DeleteFile strNewPath
FSO.MoveFile strFilePath, strNewPath
Expand All @@ -261,7 +249,7 @@ Public Sub MoveFolderIfExists(strFolderPath As String, strToParentFolder As Stri
Dim strNewPath As String
If FSO.FolderExists(strFolderPath) Then
Perf.OperationStart "Move Folder"
MkDirIfNotExist strToParentFolder
VerifyPath strToParentFolder
strNewPath = StripSlash(strToParentFolder) & PathSep & FSO.GetFolder(strFolderPath).Name
If FSO.FolderExists(strNewPath) Then FSO.DeleteFolder strNewPath, True
FSO.MoveFolder strFolderPath, strNewPath
Expand Down Expand Up @@ -299,66 +287,73 @@ Public Sub ClearFilesByExtension(ByVal strFolder As String, strExt As String)
End Sub


'---------------------------------------------------------------------------------------
' Procedure : VerifyPath
' Author : Adam Waller
' Date : 8/3/2020
' Purpose : Verifies that the folder path to a folder or file exists.
' : Use this to verify the folder path before attempting to write a file.
'---------------------------------------------------------------------------------------
'
Public Sub VerifyPath(strPath As String)

' ----------------------------------------------------------------
' Procedure : VerifyPath (Renamed from EnsurePathExists)
' DateTime : 8/15/2022, 10/24/2024
' Author : Mike Wolfe, hecon5
' Source : https://nolongerset.com/ensurepathexists/
' Purpose : Unicode-safe method to ensure a folder exists and
' : create the folder (and all subfolders) if it does not.
' : Added in additional error handling and logging.
' ----------------------------------------------------------------
Public Function VerifyPath(ByRef PathToCheck As String _
, Optional ByVal EnableLongPath As Boolean = True) As Boolean

Const FunctionName As String = ModuleName & ".VerifyPath"

Const ERROR_SUCCESS As Long = &H0
Const ERROR_ACCESS_DENIED As Long = &H5 'Could not create directory; access denied.
Const ERROR_BAD_PATHNAME As Long = &HA1 'The pszPath parameter was set to a relative path.
Const ERROR_FILENAME_EXCED_RANGE As Long = &HCE 'The path pointed to by pszPath is too long.
Const ERROR_FILE_EXISTS As Long = &H50 'The directory exists.
Const ERROR_ALREADY_EXISTS As Long = &HB7 'The directory exists.
Const ERROR_CANCELLED As Long = &H4C7 'The user canceled the operation.
Const ERROR_INVALID_NAME As Long = &H7B 'Unicode path passed when SHCreateDirectoryEx passes PathToCheck as string.

Const LONG_PATH_PREFIX As String = "\\?\"

Dim ReturnCode As Long
Dim strFolder As String
Dim varParts As Variant
Dim intPart As Integer
Dim strVerified As String

If strPath = vbNullString Then Exit Sub
LogUnhandledErrors FunctionName
On Error Resume Next

Perf.OperationStart FunctionName

Perf.OperationStart "Verify Path"
If PathToCheck = vbNullString Then GoTo Exit_Here

' Determine if the path is a file or folder
If Right$(strPath, 1) = PathSep Then
If Right$(PathToCheck, 1) = PathSep Then
' Folder name. (Folder names can contain periods)
strFolder = Left$(strPath, Len(strPath) - 1)
strFolder = Left$(PathToCheck, Len(PathToCheck) - 1)
Else
' File name
strFolder = FSO.GetParentFolderName(strPath)
strFolder = FSO.GetParentFolderName(PathToCheck)
End If

' Check if full path exists.
If Not FSO.FolderExists(strFolder) Then
' Start from the root, and build out full path, creating folders as needed.
' UNC path? change 3 "\" into 3 "@"
If strFolder Like PathSep & PathSep & "*" & PathSep & "*" Then
strFolder = Replace(strFolder, PathSep, "@", 1, 3)
End If

' Separate folders from server name
varParts = Split(strFolder, PathSep)
' Get the slashes back
varParts(0) = Replace(varParts(0), "@", PathSep, 1, 3)

' Make sure the root folder exists. If it doesn't we probably have some other issue.
If Not FSO.FolderExists(varParts(0)) Then
MsgBox2 "Path Not Found", "Could not find the path '" & varParts(0) & "' on this system.", _
"While trying to verify this path: " & strFolder, vbExclamation
Else
' Loop through folder structure, creating as needed.
strVerified = varParts(0) & PathSep
For intPart = 1 To UBound(varParts)
strVerified = FSO.BuildPath(strVerified, varParts(intPart))
MkDirIfNotExist strVerified

Next intPart
End If
If EnableLongPath And Not StartsWith(strFolder, ".") Then ' Can't use relative paths for LongPaths.
ReturnCode = SHCreateDirectoryEx(ByVal 0&, StrPtr(LONG_PATH_PREFIX & strFolder), ByVal 0&)
Else
ReturnCode = SHCreateDirectoryEx(ByVal 0&, StrPtr(strFolder), ByVal 0&)
End If

' End timing of operation
Select Case ReturnCode
Case ERROR_SUCCESS, _
ERROR_FILE_EXISTS, _
ERROR_ALREADY_EXISTS
VerifyPath = True
Case ERROR_ACCESS_DENIED: Log.Error eelError, "Could not create path: Access denied. Path: " & PathToCheck
Case ERROR_BAD_PATHNAME: Log.Error eelError, "Cannot use relative path. Path: " & PathToCheck, FunctionName
Case ERROR_FILENAME_EXCED_RANGE: Log.Error eelError, "Path too long. Path: " & PathToCheck, FunctionName
Case ERROR_CANCELLED: Log.Error eelError, "User cancelled CreateDirectory operation. Path: " & PathToCheck, FunctionName
Case ERROR_INVALID_NAME: Log.Error eelError, "Invalid path name. Path: " & PathToCheck, FunctionName
Case Else: Log.Error eelError, "Unexpected error verifying path. Return Code: " & CStr(ReturnCode) & vbNewLine & vbNewLine & "Path: " & PathToCheck, FunctionName
End Select

Exit_Here:
CatchAny eelError, "Unexpected Error verifying path: " & vbNewLine & vbNewLine & PathToCheck, FunctionName
Perf.OperationEnd

End Sub
End Function


'---------------------------------------------------------------------------------------
Expand Down Expand Up @@ -449,6 +444,25 @@ Public Function ReadJsonFile(strPath As String) As Dictionary
End Function


'---------------------------------------------------------------------------------------
' Procedure : BuildPath2
' Author : Adam Waller
' Date : 3/3/2021
' Purpose : Like FSO.BuildPath, but with unlimited arguments)
'---------------------------------------------------------------------------------------
'
Public Function BuildPath2(ParamArray Segments())
Dim lngPart As Long
With New clsConcat
For lngPart = LBound(Segments) To UBound(Segments)
.Add CStr(Segments(lngPart))
If lngPart < UBound(Segments) Then .Add PathSep
Next lngPart
BuildPath2 = .GetStr
End With
End Function


'---------------------------------------------------------------------------------------
' Procedure : GetRelativePath
' Author : Adam Waller
Expand Down Expand Up @@ -527,34 +541,62 @@ End Function

'---------------------------------------------------------------------------------------
' Procedure : GetUncPath
' Author : Adam Waller
' Date : 7/14/2020
' Author : Adam Waller, hecon5
' Date : 7/14/2020, 2022 Sept 27
' Purpose : Returns the UNC path for a network location (if applicable)
'---------------------------------------------------------------------------------------
'
Public Function GetUncPath(strPath As String) As String
Public Function GetUNCPath(ByRef PathIn As String)

Dim strDrive As String
Dim strUNC As String
Const FunctionName As String = ModuleName & ".GetUNCPath"
Dim DriveLetter As String
Dim UNCPath As String

LogUnhandledErrors
LogUnhandledErrors FunctionName
On Error Resume Next

strUNC = strPath
strDrive = FSO.GetDriveName(strPath)
If strDrive <> vbNullString Then
With FSO.GetDrive(strDrive)
If .DriveType = Remote Then
strUNC = Replace(strPath, strDrive, .ShareName, , 1, vbTextCompare)
Perf.OperationStart FunctionName
UNCPath = PathIn

Retry:
DriveLetter = FSO.GetDriveName(PathIn)
If Catch(68) Then GoTo HandleDriveLoss
CatchAny eelError, "Issue getting drive paths.", FunctionName
With FSO.GetDrive(DriveLetter)
If Catch(68) Then GoTo HandleDriveLoss
If .DriveType = Remote Then
If .IsReady Then
UNCPath = Replace(PathIn, DriveLetter, .ShareName, , 1, vbTextCompare)
Else
GoTo HandleDriveLoss
End If
End With
End If
End If
End With
GetUNCPath = UNCPath

' Log warning if unable to access a drive.
CatchAny eelWarning, "Unable to determine UNC path for " & strPath, ModuleName & ".GetUncPath"
Exit_Here:
Perf.OperationEnd
CatchAny eelError, "Issue getting drive paths.", FunctionName
Exit Function

HandleDriveLoss:
' This was borrowed from our applicaion, which has more error handling, so we're doing this in two steps now.
Log.Error eelError, "Your drive isn't ready! Reconnect " & DriveLetter & " to continue." _
, FunctionName

Select Case MsgBox2("Click [Retry] AFTER reconnecting drive " & DriveLetter & " to continue." _
, "This usually just means you need to simply open the drive in File Explorer. " _
, "Click Cancel to stop operation." _
, vbRetryCancel + vbDefaultButton1 + vbExclamation _
, "Drive not ready.")

' Return UNC Path
GetUncPath = strUNC
Case vbRetry
GoTo Retry

Case Else
' Log error, quit operation.
GoTo Exit_Here
End Select

End Function

Expand Down Expand Up @@ -615,3 +657,18 @@ Public Function AddSlash(strText As String) As String
AddSlash = strText & PathSep
End If
End Function


'---------------------------------------------------------------------------------------
' Procedure : PathSep
' Author : Adam Waller
' Date : 3/3/2021
' Purpose : Return the current path separator, based on language settings.
' : Caches value to avoid extra calls to FSO object.
'---------------------------------------------------------------------------------------
'
Public Function PathSep() As String
Static strSeparator As String
If strSeparator = vbNullString Then strSeparator = Mid$(FSO.BuildPath("a", "b"), 2, 1)
PathSep = strSeparator
End Function
34 changes: 0 additions & 34 deletions Version Control.accda.src/modules/modFunctions.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -652,40 +652,6 @@ Public Function ZNDate(varValue As Variant) As Variant
End Function


'---------------------------------------------------------------------------------------
' Procedure : PathSep
' Author : Adam Waller
' Date : 3/3/2021
' Purpose : Return the current path separator, based on language settings.
' : Caches value to avoid extra calls to FSO object.
'---------------------------------------------------------------------------------------
'
Public Function PathSep() As String
Static strSeparator As String
If strSeparator = vbNullString Then strSeparator = Mid$(FSO.BuildPath("a", "b"), 2, 1)
PathSep = strSeparator
End Function


'---------------------------------------------------------------------------------------
' Procedure : BuildPath2
' Author : Adam Waller
' Date : 3/3/2021
' Purpose : Like FSO.BuildPath, but with unlimited arguments)
'---------------------------------------------------------------------------------------
'
Public Function BuildPath2(ParamArray Segments())
Dim lngPart As Long
With New clsConcat
For lngPart = LBound(Segments) To UBound(Segments)
.Add CStr(Segments(lngPart))
If lngPart < UBound(Segments) Then .Add PathSep
Next lngPart
BuildPath2 = .GetStr
End With
End Function


'---------------------------------------------------------------------------------------
' Procedure : Nz2
' Author : Adam Waller
Expand Down
26 changes: 19 additions & 7 deletions Version Control.accda.src/modules/modObjects.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -155,19 +155,31 @@ End Function

'---------------------------------------------------------------------------------------
' Procedure : FSO
' Author : Adam Waller
' Date : 1/18/2019
' Author : Adam Waller, hecon5
' Date : 1/18/2019, 10/24/2024
' Purpose : Wrapper for file system object. A property allows us to clear the object
' : reference when we have completed an export or import operation.
'---------------------------------------------------------------------------------------
'
Public Property Get FSO() As Scripting.FileSystemObject
If this.FSO Is Nothing Then
If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next
Set this.FSO = New Scripting.FileSystemObject
CatchAny eelCritical, "Unable to create Scripting.FileSystemObject", ModuleName & ".FSO"
End If

Const FunctionName As String = ModuleName & ".FSO"
Static RetryCount As Long

LogUnhandledErrors FunctionName
On Error Resume Next

Retry:
If this.FSO Is Nothing Then Set this.FSO = New Scripting.FileSystemObject
Set FSO = this.FSO
If CatchAny(eelError, "Retry FSO Check", FunctionName, False, True) And RetryCount < 2 Then
' Some machines in some environments may fail to generate the FileSystemObject the first time
' 99% of the time, the second attempt will work. This may be due to a race condition in the OS.
RetryCount = RetryCount + 1
GoTo Retry
End If
CatchAny eelCritical, "Unable to create Scripting.FileSystemObject", FunctionName

End Property


Expand Down