Attribute VB_Name = "modFS"
' -------------------------------------------------------------------------------
'
'   AVStoDVD - by MrC
'   File: modFS.bas
'   Purpose: File System useful functions
'
' -------------------------------------------------------------------------------


Public Enum DRIVE_STATUS
    DRIVE_DOESNT_EXIST = 1
    DRIVE_NOT_READY = 2
    DRIVE_READY = 3
End Enum

Const SEM_FAILCRITICALERRORS = &H1

Declare Function GetDiskFreeSpace Lib "KERNEL32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
    lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Declare Function GetDiskFreeSpaceEx Lib "KERNEL32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, _
    lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long
Declare Function api_SetErrorMode Lib "KERNEL32" Alias "SetErrorMode" (ByVal fuErrorMode As Long) As Long
Declare Function GetDriveType Lib "KERNEL32" Alias "GetDriveTypeA" (ByVal lpRootPathName As String) As Long
Declare Function GetVolumeInformation Lib "KERNEL32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long


' Retrieve the FileName list inside a Path
Public Function FileList(ByVal Path As String, ByVal FileFilter As String, Optional ByVal AttrFilter As Integer) As Collection
   
    '   AttrFilter vbValues
    '   ----------------------------------------------------
    '   vbNormal     0  Normal (default for Dir and SetAttr)
    '   vbReadOnly   1  Read-only
    '   vbHidden     2  Hidden
    '   vbSystem     4  System file
    '   vbVolume     8  Volume label
    '   vbDirectory  16 Directory or folder
    '   vbArchive    32 File has changed since last backup
   
    Dim Name As String
    Dim PathMod As String
    
    On Error GoTo Err_Handling
        
    Set FileList = New Collection
    Name = Dir(Path, vbDirectory)   ' Path verification
    If Name = "" Then Exit Function
    If Right(Path, 1) = "\" Then
        PathMod = Path
    Else
        PathMod = Path & "\"
    End If
    Name = Dir(PathMod & FileFilter, AttrFilter)
    Do While Name <> ""
       If Name <> "." And Name <> ".." Then
            If (GetAttr(PathMod & Name) And AttrFilter) = AttrFilter Then
                FileList.add Name, Name  ' Add file to collection
            End If
       End If
       Name = Dir
    Loop
    
    Exit Function
    
Err_Handling:
Set FileList = Nothing
   
End Function


' Retrieve the FileName (name+extension) of a PathName
Public Function FileNameOf(ByVal PathName As String) As String
     
    Dim jj As Integer
     
    On Error GoTo NoFileName
     
    ' Get file title
    If PathName <> "" Then
        For jj = Len(PathName) To 0 Step -1
            If Mid(PathName, jj, 1) <> "\" Then
                FileNameOf = Mid(PathName, jj, 1) & FileNameOf
            Else
                Exit For
            End If
        Next jj
    End If
     
NoFileName:
     
End Function


' Retrieve the path of a PathName
' It requires FileNameOf()
Public Function PathOf(ByVal PathName As String, Optional BackSlashLast As Boolean = True) As String
     
     On Error GoTo NoPath
     
     ' Return path only
     PathOf = Left(PathName, Len(PathName) - Len(FileNameOf(PathName)))
     
     If BackSlashLast = False And Len(PathOf) > 0 Then
        PathOf = Left(PathOf, Len(PathOf) - 1)
     End If
     
NoPath:
     
End Function


' Retrieve the extension of a pathname
Public Function ExtOf(ByVal PathName As String) As String
     
     Dim jj As Integer
     
     On Error GoTo NoExt
     
     If PathName <> "" Then
        For jj = Len(PathName) To 1 Step -1
            If InStr(jj, PathName, ".") <> 0 Then
                ExtOf = Mid(PathName, jj + 1, Len(PathName) - jj + 1)
                Exit For
            End If
        Next jj
     End If
     
NoExt:
     
End Function


' Retrieve the name of a PathName, without extension
' It requires ExtOf() and FileNameOf()
Public Function NameOf(ByVal PathName As String) As String
     
     Dim Filename As String
     Dim FileExt As String
     
     On Error GoTo NoName
     
     If PathName <> "" Then
        Filename = FileNameOf(PathName)
        FileExt = ExtOf(PathName)
        NameOf = Left(Filename, Len(Filename) - Len(FileExt) - 1)
     End If
     
NoName:
     
End Function


' Rename a file or folder
Public Sub ReName(InputPathname, OutputPathname, Optional Overwrite As Boolean = True)

    If Dir(InputPathname) <> "" Or Dir(InputPathname, vbDirectory) <> "" Then
        If Overwrite = True And LCase(InputPathname) <> LCase(OutputPathname) Then
            If Dir(OutputPathname) <> "" Then
                Kill OutputPathname
            ElseIf Dir(OutputPathname, vbDirectory) <> "" Then
                RmDir OutputPathname
            End If
        End If
        Name InputPathname As OutputPathname
    End If
    
End Sub


' Check if a file (PathName) exists
Public Function EsisteFile(PathName As String, Optional CaseSensitive As Boolean, Optional Attributes As VbFileAttribute) As Boolean

    ' vbNormal   0 (Default) Specifies files with no attributes.
    ' vbReadOnly 1 Specifies read-only files in addition to files with no attributes.
    ' vbHidden   2 Specifies hidden files in addition to files with no attributes.
    ' VbSystem   4 Specifies system files in addition to files with no attributes

    Dim NomeFile As String
    Dim CheckEnviron As String
    Dim jj As Integer
    Dim kk As Integer
    
    On Error GoTo Err_Handling

    If InStr(1, PathName, "%") > 0 Then
        kk = 0
        CheckEnviron = ""
        For jj = 1 To Len(PathName)
            If Mid(PathName, jj, 1) <> "%" Then
                CheckEnviron = CheckEnviron & Mid(PathName, jj, 1)
            Else
                kk = kk + 1
            End If
            If kk = 2 Then Exit For
        Next jj
        If CheckEnviron <> "" Then
            If Environ(CheckEnviron) <> "" Then
                PathName = Replace(PathName, "%" & CheckEnviron & "%", Environ(CheckEnviron))
            End If
        End If
    End If
    
    NomeFile = ""
    jj = 1
    Do
        NomeFile = Right(PathName, jj)
        jj = jj + 1
    Loop Until Left(NomeFile, 1) = "\" Or Len(NomeFile) = Len(PathName)
    If Left(NomeFile, 1) = "\" Then
        NomeFile = Right(NomeFile, Len(NomeFile) - 1)
    End If
    If CaseSensitive = False Then
        If UCase(Dir(PathName, Attributes)) = UCase(NomeFile) Then EsisteFile = True
    Else
        If Dir(PathName, Attributes) = NomeFile Then EsisteFile = True
    End If
    
    Exit Function

Err_Handling:
EsisteFile = False

End Function


' Check if a folder exists
Public Function EsisteDir(Directory As String, Optional CaseSensitive As Boolean, Optional Attributes As VbFileAttribute) As Boolean

    ' vbNormal   0 (Default) Specifies dir with no attributes.
    ' vbReadOnly 1 Specifies read-only dir in addition to dir with no attributes.
    ' vbHidden   2 Specifies hidden dir in addition to dir with no attributes.
    ' VbSystem   4 Specifies system dir in addition to dir with no attributes

    Dim NomeDir As String
    Dim jj As Integer
    
    On Error GoTo Gestione_Errori

    NomeDir = ""
    jj = 1
    Do
        NomeDir = Right(Directory, jj)
        jj = jj + 1
    Loop Until Left(NomeDir, 1) = "\" Or Len(NomeDir) = Len(Directory)
    If Left(NomeDir, 1) = "\" Then
        NomeDir = Right(NomeDir, Len(NomeDir) - 1)
    End If
    If Len(NomeDir) = 2 And Right(NomeDir, 1) = ":" Then
        Select Case atDriveType(Left(NomeDir, 1))
        Case 2, 3, 4, 6
            EsisteDir = True
        Case Else
            EsisteDir = False
        End Select
    Else
        If CaseSensitive = False Then
            If UCase(Dir(Directory, vbDirectory + Attributes)) = UCase(NomeDir) Then EsisteDir = True
        Else
            If Dir(Directory, vbDirectory + Attributes) = NomeDir Then EsisteDir = True
        End If
    End If
    
    Exit Function

Gestione_Errori:
EsisteDir = False

End Function


' Delete file/dir if they exist
Public Sub DeleteIfExist(PathName As String, Optional IsDir As Boolean = False)

    On Error GoTo Err_Handling
    
    Select Case IsDir
    Case False
        If EsisteFile(PathName) = True Then Kill PathName
    Case True
        If EsisteDir(PathName) = True Then
            If Right(PathName, 1) = "\" Then PathName = Left(PathName, Len(PathName) - 1)
            If Dir(PathName & "\*.*") <> "" Then Kill PathName & "\*.*"
            DoEvents
            If Dir(PathName & "\*.*") = "" Then RmDir PathName
        End If
    End Select
    
    Exit Sub
    
Err_Handling:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbCritical, App.Title & " (Function 'DeleteIfExist')"

End Sub


' Create a folder
Public Function CreateDir(Directory As String) As Boolean

    Dim arDirs() As String
    Dim jj As Integer
    Dim DirTemp As String
    
    On Error GoTo Err_Handling
    
    arDirs = Split(Directory, "\")
    For jj = 0 To UBound(arDirs)
        If arDirs(jj) <> "" Then
            DirTemp = DirTemp & arDirs(jj) & "\"
            If Dir(DirTemp, vbDirectory) = "" Then
                MkDir DirTemp
            End If
        End If
    Next
    CreateDir = True

    Exit Function
    
Err_Handling:
CreateDir = False
    
End Function


'*****************************************************
'Scope  : Output free disc space (or total disc space)
'Input  : Logical drive unit letter
'Output : Logical drive unit free space
'*****************************************************
Function atDiskFreeSpaceEx(Drive As String, Optional bTotalSpace As Boolean) As String

    Dim dwResult
    Dim TotalSpace As Long
    Dim TotalSpaceMB As Double, FreeSpace As Long, FreeSpaceMB As Double, PercentFree As Single
    Dim Path As String
    Dim FreeBytesCaller As Currency, TotalBytes As Currency, TotalFreeBytes As Currency
    Dim Sectors As Long, Bytes As Long, FClusters As Long, TClusters As Long
    Dim ErrorMode&
    Dim sDrive As String
      
    On Error GoTo Err_DF
      
    If IsNull(Drive) = True Then Exit Function
    If Drive = "" Then Exit Function
    sDrive = LCase(Left(Drive, 1))
    If Asc(sDrive) < 97 Or Asc(sDrive) > 122 Then Exit Function
    
    ErrorMode = api_SetErrorMode(SEM_FAILCRITICALERRORS)
    dwResult = Dir(sDrive & ":\*.*")
    
    Path = sDrive & ":\" & Chr$(0)
    
    On Error Resume Next
    
    dwResult = GetDiskFreeSpaceEx(Path, FreeBytesCaller, TotalBytes, TotalFreeBytes)
    If Err = 0 Then
        TotalSpaceMB = ((TotalBytes * 10000) / 1024) / 1024
        FreeSpaceMB = ((FreeBytesCaller * 10000) / 1024) / 1024
    Else
        'Win95 OSR1
        dwResult = GetDiskFreeSpace(Path, Sectors, Bytes, FClusters, TClusters)
        TotalSpace = Sectors * Bytes * TClusters
        TotalSpaceMB = (TotalSpace / 1024) / 1024
        FreeSpace = Sectors * Bytes * FClusters
        FreeSpaceMB = (FreeSpace / 1024) / 1024
    End If
    On Error GoTo Err_DF
    PercentFree = (FreeSpaceMB / TotalSpaceMB) * 100
    If TotalSpaceMB = -1 Then
        atDiskFreeSpaceEx = "Unit not ready"
    ElseIf bTotalSpace = False Then
        atDiskFreeSpaceEx = Int(FreeSpaceMB)
    Else
        atDiskFreeSpaceEx = Int(TotalSpaceMB)
    End If
    ErrorMode = api_SetErrorMode(ErrorMode)
    
Exit_DF:
    Exit Function
    
Err_DF:
    If Err = 71 Then
        MsgBox "No disc detected in drive " & sDrive & ":, " & _
        vbCrLf & "drive door is not closed," & _
        vbCrLf & "or current disc is not formatted.", 16, "System Info"
    ElseIf Err = 68 Then
        atDiskFreeSpaceEx = ""
        Resume Exit_DF
    ElseIf Err = 75 Or 76 Then
        MsgBox "Drive " & sDrive & ": not ready ." & _
        vbCrLf & "If CDROM unit, please make sure is connected and/or disc is in." & _
        vbCrLf & "If network unit, check connection.", 16, "System Info"
    ElseIf Err = 3043 Then
        MsgBox "Error: network or disc drive " & sDrive & ": is not ready.", 48, "System Info"
    Else
        MsgBox "Error " & Error$, 48, "System Info"
    End If
    ErrorMode = api_SetErrorMode(ErrorMode)
    atDiskFreeSpaceEx = ""
    Resume Exit_DF
    
End Function
    

'***************************************************
'Scope  :  Identify a logical drive unit
'
'Input  :  Logical unit drive letter
'Output :  Unit drive type:
'          0 o 1 unknown
'          2 removable drive unit
'          3 hard drive unit
'          4 network drive unit
'          5 CDROM drive unit
'          6 RAM drive unit
'***************************************************
Public Function atDriveType(Drive As String) As Integer
    
    Dim wResult As Long
    Dim Path As String
    
    On Error GoTo Err_DT
    
    Path = Drive & ":\" & Chr$(0)
    wResult = GetDriveType(Path)
    
    atDriveType = wResult
    
    Exit Function

Err_DT:
atDriveType = 0

End Function


' Display Drive's File Allocation Table
Public Function atFATType(Drive As String) As String

    Dim Serial As Long
    Dim VName As String
    Dim FSName As String

    'Create buffers
    VName = String$(255, Chr$(0))
    FSName = String$(255, Chr$(0))
    'Get the volume information
    GetVolumeInformation UCase(Left(Drive, 2)) & "\", VName, 255, Serial, 0, 0, FSName, 255
    'Strip the extra chr$(0)'s
    atFATType = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)

End Function


' Display Drive's Volume Label
Public Function atVolumelabel(ByVal Drive As String) As String

    Dim lpVolumeNameBuffer As String, LenBuffer As Long
    Dim lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long
    Dim lpFileSystemFlags As Long, lpFileSystemNameBuffer As String
    
    LenBuffer = 256
    lpVolumeNameBuffer = Space(LenBuffer)
    lpFileSystemNameBuffer = Space(LenBuffer)
    If GetVolumeInformation(Left(Drive, 1) & ":\", _
                            lpVolumeNameBuffer, LenBuffer, _
                            lpVolumeSerialNumber, lpMaximumComponentLength, _
                            lpFileSystemFlags, _
                            lpFileSystemNameBuffer, LenBuffer) Then
        Sz2Str lpVolumeNameBuffer
        atVolumelabel = lpVolumeNameBuffer
    End If
    
End Function


' Display Drive's Status
Public Function DriveStatus(ByVal Drive As String) As DRIVE_STATUS

    Dim lDriveType As Long, lFreeSpace As Long
    Dim sDrive As String
    Dim FreeBytesCaller As Currency, TotalBytes As Currency, TotalFreeBytes As Currency
    
    sDrive = Left(Drive, 1) & ":\"
    lDriveType = GetDriveType(sDrive)
    If lDriveType = 1 Then
        DriveStatus = DRIVE_DOESNT_EXIST
    Else
        lFreeSpace = GetDiskFreeSpaceEx(sDrive, FreeBytesCaller, TotalBytes, TotalFreeBytes)
        DriveStatus = IIf(Err.LastDllError > 0, DRIVE_NOT_READY, DRIVE_READY)
    End If

End Function


Private Function Sz2Str(ByRef a_Src As String)

    Dim ch As Long
    
    ch = InStr(1, a_Src, vbNullChar, vbBinaryCompare)
    If (ch) Then a_Src = Left$(a_Src, ch - 1)
    
End Function



