'Module:        ComFile
'Purpose:       Common file handling functions
'VB Version:    Excel 97 SR-1
'Written by:    David Crawford
'
Option Explicit

Private Declare Function GetFileAttributes _
    Lib "kernel32" _
    Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
'
'Purpose:   Create a directory handling file errors
'Examples:  CreateDirectory("C:\DeleteMe")
'
Function CreateDirectory(PathAndDirectoryName As String) As Boolean
On Error GoTo HandleErrors

    'assume directory cannot be created
    CreateDirectory = False
    
    MkDir PathAndDirectoryName
    
    CreateDirectory = False
   
ExitProcedure:

    Exit Function
        
HandleErrors:

    MsgFileError "CreateDirectory", PathAndDirectoryName, Err
    Resume ExitProcedure
   
End Function
'
'Purpose:   Deletes a file handling errors
'Examples:  DeleteFile("C:\AUTOEXEC.BAT") -> true
'
Function DeleteFile(FilePath As String) As Boolean
On Error GoTo HandleErrors

    Dim MsgBoxReply As Integer
    Dim Prompt As String
    
    'delete file and return true
    Kill FilePath
    DeleteFile = True
    
ExitProcedure:

    Exit Function
        
HandleErrors:

    'return false
    DeleteFile = False
    
    'if no disk in drive
    If Err = ERR_DISKNOTREADY Then
    
        Prompt = "Put a floppy disk in the drive and close the drive door."
        MsgBoxReply = MsgBox(Prompt, vbInformation + vbOKCancel, BOX_TITLE)
        
        If MsgBoxReply = vbOK Then
            Resume
        ElseIf MsgBoxReply = vbCancel Then
            End
        Else
            Resume Next
        End If
    
    'if path or drive does not exist
    ElseIf Err = ERR_DEVICEUNAVAILABLE Then
        MsgBox _
            "This drive or path does not exist:" & CRLF() & _
            FilePath, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
    
    'if path not Found
    ElseIf Err = ERR_PATHNOTFound Then
        MsgBox _
            "This path does not exist:" & CRLF() & _
            FilePath, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
   
    'FilePath not Found
    ElseIf Err = ERR_FILENOTFound Then
        DeleteFile = True
    
    'Permission denied or FilePath/Path access error
    ElseIf Err = 70 Or Err = 75 Then
        MsgBox _
            "Could not delete FileName:" & CRLF() & _
            FilePath & CRLF() & CRLF() & _
            "Check if file is already open, if disk is write " & _
            "protected and network rights if FileName is on a network " & _
            "drive.", _
            vbInformation + vbOKOnly, _
            BOX_TITLE
    
    'Other errors
    Else
        MsgErr "DeleteFile", Err
    End If
    
    Resume ExitProcedure
    
End Function
'
'Purpose:   Return array of files in a directory sorted aphlabetically
'Arguments: <FilePath>
'
Function GetFileNamesArray( _
    FilePath As String) As Variant
On Error GoTo HandleError
    
    Dim FileName As String
    Dim FileNamesArray() As String
    Dim FileNamesIndex As Integer
    Dim FileNamesCount As Integer
 
    'add file names to file names array
    FileName = Dir(FilePath)
    FileNamesIndex = 0
    Do While Len(FileName) > 0
       
        'add FileName to FileName array
        ReDim Preserve FileNamesArray(FileNamesIndex)
        FileNamesArray(FileNamesIndex) = FileName
        
        'increase FileNames array index
        FileNamesIndex = FileNamesIndex + 1
        
        'get next FileName
        FileName = Dir
            
    Loop
    
    'if files found sort array and return
    If UBound(FileNamesArray, 1) Then
        SortArray FileNamesArray
        GetFileNamesArray = FileNamesArray
    End If
    
ExitProcedure:

    Exit Function
    
HandleError:
    
    GetFileNamesArray = False
    Resume ExitProcedure
   
End Function
'
'Purpose:   Returns True if the directory exists.
'Arguments: <DirectoryPath> Directory name and path e.g. C:\Windows
'
Function IsDirectory(DirectoryPath As String) As Boolean
On Error GoTo HandleErrors

    Dim DirectoryName As String
    
    'if directory exists return true
    DirectoryName = Dir(DirectoryPath, vbDirectory)
    If UCase$(DirectoryName) = UCase$(GetDirectory(DirectoryPath)) Then
    
        IsDirectory = True
        GoTo ExitProcedure
    
    Else
    
        IsDirectory = False
        GoTo ExitProcedure
     
    End If
    
ExitProcedure:

    Exit Function

HandleErrors:

    IsDirectory = False
    MsgFileError "IsDirectory", DirectoryPath, Err
    
End Function
'
'Purpose:   Returns True if the file exists. Optionally displays file errors.
'Arguments: <FileName> Name of the file to test.
'           [DisplayErrors] True display file errors.
'Examples:  []
'
Function IsFile( _
    FileName As String, _
    Optional DisplayErrors As Boolean = False) As Boolean
    
On Error GoTo HandleErrors

    Dim FileNameFound As String
    Dim MsgBoxResponse As Integer
       
    'if no FileName passed
    If Len(FileName) = 0 Then
    
        'display error message and return false
        If DisplayErrors Then
            MsgBox "You must select a file.", vbInformation, BOX_TITLE
        End If
        IsFile = False
        Exit Function
        
    End If
    
    'if file exist return true
    FileNameFound = Dir(FileName)
    If UCase$(FileNameFound) = UCase$(GetFileName(FileName)) Then
    
        IsFile = True
        Exit Function
        
    'else display error message and return false
    Else
        
        If DisplayErrors Then
            MsgBox _
                "Cannot find:" & CRLF() & UCase$(FileName), _
                vbInformation + vbOKOnly, _
                BOX_TITLE
        End If
        IsFile = False
        Exit Function
        
    End If
    
ExitProcedure:

    Exit Function
    
HandleErrors:

    'return false
    IsFile = False
    
    'if no error messages exit function
    If DisplayErrors = False Then Exit Function
    
    'if no disk in drive
    If Err = ERR_DISKNOTREADY Then
    
        MsgBoxResponse = MsgBox( _
            "Put a floppy disk in the drive and close the drive door.", _
            vbInformation + vbOKCancel, _
            BOX_TITLE)
        
        'if user clicked OK resume
        If MsgBoxResponse = vbOK Then
            Resume
        
        'if user clicked cancel end
        ElseIf MsgBoxResponse = vbCancel Then
            End
            
        End If
    
    'if path or drive does not exist tell
    ElseIf Err = ERR_DEVICEUNAVAILABLE Then
        MsgBox _
            "This drive or path does not exist:" & CRLF() & FileName, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
        Exit Function
    
    'if path not found tell user and exit function
    ElseIf Err = ERR_PATHNOTFound Then
        MsgBox _
            "This path does not exist:" & CRLF() & UCase$(FileName), _
            vbInformation + vbOKOnly, _
            BOX_TITLE
        Exit Function

    'if other error tell user and end
    Else
        MsgErr "IsFile", Err
        End
    End If
    
End Function
'
'Purpose:   Gets the directory from a well formed FilePath.
'Examples:  GetDirectory("C:\WINDOWS\TEMP.TXT") -> "C:\WINDOWS"
'
Function GetDirectory(FileName As String) As String
    
    Dim FileNameLength As Integer
    Dim FileNameIndex As Integer
    
    'search from end of FileName
    FileNameLength = Len(FileName)
    For FileNameIndex = FileNameLength To 1 Step -1
        
        'if character is backslash then return directory
        If Mid$(FileName, FileNameIndex, 1) = "\" Then
            GetDirectory = Left(FileName, FileNameIndex - 1)
            Exit Function
        End If
    
    Next FileNameIndex
    
    'return "" if FileName does not have directory
    GetDirectory = ""
    
End Function
'
'Purpose:   Gets the drive from a well formed FileName.
'Examples:  GetDrive("C:\WINDOWS\TEMP.TXT") -> "C"
'
Function GetDrive(FileName As String) As String
    
    GetDrive = Left(FileName, 1)
    
End Function
'
'Purpose:   Return the extension from a FileName.
'Examples:  getExtension("TEMP.TXT") -> "TXT"
'           getExtension("TEMP") -> ""
'
Function GetExtension(FileName As String) As String
    
    Dim FileNameLength As Integer
    Dim FileNameIndex As Integer
        
    'for each character starting at end of FileName
    FileNameLength = Len(FileName)
    For FileNameIndex = FileNameLength To 1 Step -1
        
        'if character is Period then return extension
        If Mid$(FileName, FileNameIndex, 1) = "." Then
            GetExtension = Mid$( _
                FileName, _
                FileNameIndex + 1, _
                FileNameLength - FileNameIndex)
            Exit Function
        End If
    
    Next FileNameIndex
    
    'return "" if FileName does not have extension
    GetExtension = ""
    
End Function
'
'Purpose:   Get the FilePath from a well formed FilePath.
'Examples:  GetFileName("C:\WINDOWS\TEMP.TXT") -> "TEMP.TXT"
'           GetFileName("TEMP.TXT") -> "TEMP.TXT"
'
Function GetFileName(FilePath As String) As String
    
    Dim FilePathLength As Integer
    Dim FilePathIndex As Integer
    
    'for each character starting at end of full FileName
    FilePathLength = Len(FilePath)
    For FilePathIndex = FilePathLength To 1 Step -1
        
        'if character is backslash then return FileName
        If Mid$(FilePath, FilePathIndex, 1) = "\" Then
            GetFileName = Mid$( _
                FilePath, _
                FilePathIndex + 1, _
                FilePathLength - FilePathIndex)
            Exit Function
        End If
    
    Next FilePathIndex
    
    'return FilePath if FilePath does include directory
    GetFileName = FilePath
    
End Function
'
'Purpose:   Check string is a valid file extension
'Examples:  IsExtensionValid("xls") -> true
'           IsExtensionValid("?*") -> false
'
Function IsExtensionValid(Extension As String)
    
    Dim LegalCharacters As String
    Dim ExtensionIndex As Integer

    'make extension upper case so validation is not case sensitive
    Extension = UCase(Extension)
  
    'for each character in extension
    LegalCharacters = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~"
    For ExtensionIndex = 1 To Len(Extension)
    
        'if characters is illegal then return false and exit function
        If InStr(LegalCharacters, Mid$(Extension, ExtensionIndex, 1)) = 0 Then
            IsExtensionValid = False
            Exit Function
        End If
        
    Next ExtensionIndex
    
    'Extension must be valid
    IsExtensionValid = True
    
End Function
'
'Purpose:   Check file name is valid
'
Function IsFileNameValid(FileName As String)

    Dim CharacterCount As Integer
    Dim CharacterIndex As Integer
    Dim LegalCharacters As String
    
    'if FileName has more than 260 characters return false
    If Len(FileName) > 260 Then
    
        IsFileNameValid = False
        
    End If
    
    'if FileName contains invalid characters return false
    LegalCharacters = ".:\!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~"
    CharacterCount = Len(FileName)
    For CharacterIndex = 1 To CharacterCount
    
        'test for illegal characters
        If InStr(LegalCharacters, UCase$(Mid$(FileName, CharacterIndex, 1))) = 0 Then
        
            Exit Function
            
        End If
        
    Next CharacterIndex
    
    IsFileNameValid = True
    
End Function
'
'Purpose:   Gets the main name from a well formed FileName.
'Examples:  GetFileNameMain("C:\WINDOWS\TEMP.TXT") -> "TEMP"
'           GetFileNameMain("TEMP.TXT") -> "TEMP"
'
Function GetFileNameMain(FilePath As String) As String

    Dim FileName As String
    Dim FileNameLength As Integer
    Dim FileNameIndex As Integer
    
    FileName = GetFileName(FilePath)
    
    'search from end of FileName
    FileNameLength = Len(FileName)
    For FileNameIndex = FileNameLength To 1 Step -1
        
        'if character is Period then return main FileName
        If Mid$(FileName, FileNameIndex, 1) = "." Then
            GetFileNameMain = Left(FileName, FileNameIndex - 1)
            Exit Function
        End If
    
    Next FileNameIndex
    
    'return FileName if FileName does not have extension
    GetFileNameMain = FileName
    
End Function
'
'Purpose:   Display a standard file error messages
'
Sub MsgFileError( _
    ProcedureName As String, _
    FileName As String, _
    ErrorNumber As Integer)
    
    Dim MsgBoxReply
    
    'if no disk in drive
    If ErrorNumber = ERR_DISKNOTREADY Then
    
        MsgBoxReply = MsgBox( _
            "Put a floppy disk in the drive and close the drive door.", _
            vbInformation + vbOKCancel, _
            BOX_TITLE)
        
        If MsgBoxReply = vbOK Then
            Resume
        ElseIf MsgBoxReply = vbCancel Then
            End
        Else
            Resume Next
        End If
    
    'if path or drive does not exist
    ElseIf ErrorNumber = ERR_DEVICEUNAVAILABLE Then
        MsgBox _
            "This drive or path does not exist:" & CRLF() & _
            FileName, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
    
    'if path not Found
    ElseIf ErrorNumber = ERR_PATHNOTFound Then
        MsgBox _
            "This path does not exist:" & CRLF() & _
            FileName, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
   
    'permission denied or FileName/Path access error
    ElseIf ErrorNumber = 70 Or ErrorNumber = 75 Then
        MsgBox _
            "Could not access file: " & FileName & CRLF() & _
            "Check if file is already open, if disk is write " & _
            "protected and network rights if file is on a network " & _
            "drive.", _
            vbInformation + vbOKOnly, _
            BOX_TITLE
    
    'Other errors
    Else
        MsgBox _
            "An unexpected file error has occurred." & CRLF() & CRLF() & _
            "Procedure: " & ProcedureName & CRLF() & _
            "FileName: " & FileName & CRLF() & _
            "Error Number: " & ErrorNumber, _
            vbInformation + vbOKOnly, _
            BOX_TITLE
    End If
    
End Sub
'
'Purpose:   Remove a directory
'Argument:  <PathAndDirectory> Path and name of directory to remove.
'Examples:  RemoveDirectory("C:\DeleteMe")
'
Function RemoveDirectory(PathAndDirectoryName As String) As Boolean
On Error GoTo HandleErrors

    'assume directory cannot be created
    RemoveDirectory = False
    
    'ChDrive GetDrive(PathAndDirectoryName)
    RmDir PathAndDirectoryName
    
    RemoveDirectory = True
   
ExitProcedure:

    Exit Function
        
HandleErrors:

    MsgFileError "CreateDirectory", PathAndDirectoryName, Err
    Resume ExitProcedure
   
End Function