openaccess/source/modules/VCS_Dir.bas

Option Compare Database
Option Private Module
Option Explicit

 Private Declare Function PathIsRelative Lib "Shlwapi" _
        Alias "PathIsRelativeA" (ByVal Path As String) As Long

    Public Enum EMakeDirStatus
        ErrSuccess = 0
        ErrRelativePath
        ErrInvalidPathSpecification
        ErrDirectoryCreateError
        ErrSpecIsFileName
        ErrInvalidCharactersInPath
    End Enum
    Const MAX_PATH = 260
    
' Path/Directory of the current database file.
Public Function ProjectPath() As String
    ProjectPath = CurrentProject.Path
    If Right$(ProjectPath, 1) <> "\" Then ProjectPath = ProjectPath & "\"
End Function

' Path/Directory for source files
Public Function SourcePath() As String
    SourcePath = ProjectPath & CurrentProject.name & ".src\"
End Function

' Create folder `Path`. Silently do nothing if it already exists.
Public Sub MkDirIfNotExist(ByVal Path As String)
    On Error GoTo MkDirIfNotexist_noop
    MkDir Path
    logger "MkDirIfNotExist", "INFO", "New dir created: " & Path
MkDirIfNotexist_noop:
    On Error GoTo 0
End Sub



' Delete a file if it exists.
Public Sub DelIfExist(ByVal Path As String)
    On Error GoTo DelIfNotExist_Noop
    Kill Path
    logger "DelIfExist", "DEBUG", "Killed: " & Path
DelIfNotExist_Noop:
    On Error GoTo 0
End Sub

' Erase all *.`ext` files in `Path`.
Public Sub ClearTextFilesFromDir(ByVal Path As String, ByVal Ext As String, Optional ByVal force As Boolean = False)
    
    '### 13/10/2016: add optimizer
    ' we don't want to clear the text files of the objects which will not be exported
    'BUT we still want to clear obsolete files: see CleanDirs in optimizer
    If optimizer_activated() And Not force Then
        logger "ClearTextFilesFromDir", "INFO", "Optimizer on: sub aborted"
        Exit Sub
    End If
    '###
    
    logger "ClearTextFilesFromDir", "DEBUG", "Clear dir: " & Path & "*." & Ext

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(Path) Then Exit Sub

    On Error GoTo ClearTextFilesFromDir_noop
    If dir$(Path & "*." & Ext) <> vbNullString Then
        FSO.DeleteFile Path & "*." & Ext
    End If
    
ClearTextFilesFromDir_noop:
    On Error GoTo 0
End Sub

Public Function DirExists(ByVal strPath As String) As Boolean
    On Error Resume Next
    DirExists = False
    DirExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Public Function FileExists(ByVal strPath As String) As Boolean
    On Error Resume Next
    FileExists = False
    FileExists = ((GetAttr(strPath) And vbDirectory) <> vbDirectory)
End Function



    
Function RecursiveMkDir(ByVal PathSpec As String) As EMakeDirStatus
    ' This function creates a series of nested directories. The parent of
    ' every directory is create before a subdirectory is created, allowing a
    ' folder path specification of any number of directories (as long as the
    ' total length is less than MAX_PATH.
    
    Dim FSO As Scripting.FileSystemObject
    Dim DD As Scripting.Drive
    Dim B As Boolean
    Dim Root As String
    Dim DirSpec As String
    Dim N As Long
    Dim M As Long
    Dim S As String
    Dim Directories() As String
        
    Set FSO = New Scripting.FileSystemObject
        
    ' ensure there are no invalid characters in spec.
    On Error Resume Next
    err.Clear
    S = dir(PathSpec, vbNormal)
    If err.Number <> 0 Then
        RecursiveMkDir = ErrInvalidCharactersInPath
        Exit Function
    End If
    On Error GoTo 0
    
    ' ensure we have an absolute path
    B = CBool(PathIsRelative(PathSpec))
    If B = True Then
        RecursiveMkDir = ErrRelativePath
        Exit Function
    End If
    
    ' if the directory already exists, get out with success.
    If FSO.FolderExists(PathSpec) = True Then
        RecursiveMkDir = ErrSuccess
        Exit Function
    End If
    
    ' get rid of trailing slash
    If Right(PathSpec, 1) = "\" Then
        PathSpec = Left(PathSpec, Len(PathSpec) - 1)
    End If
    
    ' ensure we don't have a filename
    N = InStrRev(PathSpec, "\")
    M = InStrRev(PathSpec, ".")
    If (N > 0) And (M > 0) Then
        If M > N Then
            ' period found after last slash
            RecursiveMkDir = ErrSpecIsFileName
            Exit Function
        End If
    End If
    
    If Left(PathSpec, 2) = "\\" Then
        ' UNC -> \\Server\Share\Folder...
        N = InStr(3, PathSpec, "\")
        N = InStr(N + 1, PathSpec, "\")
        Root = Left(PathSpec, N - 1)
        DirSpec = Mid(PathSpec, N + 1)
    Else
        ' Local or mapped -> C:\Folder....
        N = InStr(1, PathSpec, ":", vbBinaryCompare)
        If N = 0 Then
            RecursiveMkDir = ErrInvalidPathSpecification
            Exit Function
        End If
        Root = Left(PathSpec, N)
        DirSpec = Mid(PathSpec, N + 2)
    End If
    Set DD = FSO.GetDrive(Root)
    Directories = Split(DirSpec, "\")
    DirSpec = DD.Path
    For N = LBound(Directories) To UBound(Directories)
        DirSpec = DirSpec & "\" & Directories(N)
        If FSO.FolderExists(DirSpec) = False Then
            On Error Resume Next
            err.Clear
            FSO.CreateFolder (DirSpec)
            If err.Number <> 0 Then
                RecursiveMkDir = ErrDirectoryCreateError
                Exit Function
            End If
        End If
    Next N
    RecursiveMkDir = ErrSuccess
    End Function