Attribute VB_Name = "mFilePath"
Option Explicit

' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Declare Function SHGetSpecialFolderPathW Lib "shell32" (ByVal hWndOwner As Long, _
    ByVal lpszPath As Long, ByVal lFolder As Long, ByVal fCreate As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathW" _
   (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long

Private Declare Function ShortPathName Lib "kernel32" Alias "GetShortPathNameW" _
   (ByVal lpszLongPath As Long, ByVal lpszShortPath As Long, ByVal cchBuffer As Long) As Long

Private Declare Function LongPathName Lib "kernel32" Alias "GetLongPathNameW" _
   (ByVal lpszShortPath As Long, ByVal lpszLongPath As Long, ByVal cchBuffer As Long) As Long

Public Declare Function SetAttributes Lib "kernel32" Alias "SetFileAttributesW" _
   (ByVal lpSpec As Long, ByVal dwAttributes As Long) As Long

Private Const DIR_SEP As String = "\"
Private Const MAX_PATH = 260&

' +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Const FO_MOVE = &H1&     ' Moves the files specified in pFrom to the location specified in pTo.
Private Const FO_COPY = &H2&     ' Copies the files specified in the pFrom member to the location specified in the pTo member.
Private Const FO_DELETE = &H3&   ' Deletes the files specified in pFrom (pTo is ignored).
Private Const FO_RENAME = &H4&   ' Renames the files specified in pFrom.

Private Const FOF_ALLOWUNDO = &H40         ' Preserve Undo information, if possible. If pFrom does not contain fully qualified path and filenames, this flag is ignored.
Private Const FOF_RENAMEONCOLLISION = &H8  ' Give the file being operated on a new name in a move, copy, or rename operation if a file with the target name already exists.
Private Const FOF_NOCONFIRMATION = &H10    ' Don't prompt the user. Respond with Yes to All for any dialog box that is displayed.
Private Const FOF_WANTMAPPINGHANDLE = &H20 ' If FOF_RENAMEONCOLLISION is specified, the hNameMappings member will be filled in if any files were renamed.
Private Const FOF_SIMPLEPROGRESS = &H100   ' Displays a progress dialog box but does not show the file names.
Private Const FOF_NOCONFIRMMKDIR = &H200   ' Don't confirm making any needed dirs. Does not confirm the creation of a new directory if the operation requires one to be created.

'+++++++++++++++++++++++++++++++++++++
Private Type SHNAMEMAPPING
    pszOldPath As String
    pszNewPath As String
    cchOldPath As Long
    cchNewPath As Long
End Type
'+++++++++++++++++++++++++++++++++++++
Private Type SHFILEOPSTRUCT
    hWnd As Long                  ' Window owner of any dialogs
    wFunc As Long                 ' Copy, move, rename, or delete code
    pFrom As String               ' Source file
    pTo As String                 ' Destination file or directory
    fFlags As Integer             ' Options to control the operations
    ''''''''''''''''''''''''''''''' VB unfriendly alignment
    fAnyOperationsAborted As Long ' Indicates partial failure
    hNameMappings As Long         ' Handle to a file name mapping object filled in if any files were renamed
    lpszProgressTitle As String   ' Title for progress dialog, only used if FOF_SIMPLEPROGRESS
End Type
'+++++++++++++++++++++++++++++++++++++

Private Declare Function SHFileOperationW Lib "shell32" (ByVal lpFileOp As Long) As Long 'SHFILEOPSTRUCT
Private Declare Sub SHFreeNameMappings Lib "shell32" (ByVal hNameMappings As Long)
Private Declare Sub CopyFileOp Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSrc As Long, ByVal lLenB As Long)

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  Private Declare Function GetDiskFreeSpaceExW Lib "kernel32" _
        (ByVal lpDrive As Long, _
         lpFreeBytesAvailableToCallerDividedBy10000 As Currency, _
         lpTotalNumberOfBytesDividedBy10000 As Currency, _
         lpTotalNumberOfFreeBytesDividedBy10000 As Currency) As Long
' Note - the values obtained by GetDiskFreeSpaceExA are ULARGE_INTEGER.
' Therefore, they are declared as Currency, and so need to be multiplied
' by 10000 to get the correct number of Bytes (moves the decimal place).
' Use the GetDiskFreeSpace32 wrapper function below.
  Private Const ERROR_CALL_NOT_IMPLEMENTED = 120&
'
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' If this function succeeds, the return value is nonzero.
Public Function GetDiskFreeSpace32(sDrive As String, FreeBytesAvailable As Currency, _
        TotalNumberOfBytes As Currency, TotalNumberOfFreeBytes As Currency) As Long

    Dim cAvailable As Currency, cTotal As Currency, cTotalFree As Currency
    Dim rc As Long, sDrv As String

    sDrv = Left$(sDrive, 3&)
    rc = GetDiskFreeSpaceExW(StrPtr(sDrv), cAvailable, cTotal, cTotalFree)

    If (rc <> ERROR_CALL_NOT_IMPLEMENTED) Then
        FreeBytesAvailable = cAvailable * 10000
        TotalNumberOfBytes = cTotal * 10000
        TotalNumberOfFreeBytes = cTotalFree * 10000
        GetDiskFreeSpace32 = rc
    End If
End Function

'-----------------------------------------------------------

Public Function GetDesktopFolder() As String
    Dim sBuffer As String
    Const sfCOMMON_DESKTOPDIR = &H19&
    sBuffer = FillNulls(MAX_PATH)
    If SHGetSpecialFolderPathW(0&, StrPtr(sBuffer), sfCOMMON_DESKTOPDIR, 0&) Then
        GetDesktopFolder = RTrimZ(sBuffer) 'TrimNulls(sBuffer)
    End If
End Function

'-----------------------------------------------------------

Public Function GetRecentFolder() As String
    Dim sBuffer As String
    Const sfRECENT = &H8&
    sBuffer = FillNulls(MAX_PATH)
    If SHGetSpecialFolderPathW(0&, StrPtr(sBuffer), sfRECENT, 0&) Then
        GetRecentFolder = RTrimZ(sBuffer) 'TrimNulls(sBuffer)
    End If
End Function

'-----------------------------------------------------------

Public Function CreateTempDir() As String
  If InAnExe Then On Error GoTo ErrHandler
    Dim sTemp As String
    sTemp = GetAppDataPath
    If CreatePath(sTemp & "Temp\") Then
        CreateTempDir = sTemp & "Temp"
    Else
        sTemp = FillNulls(MAX_PATH)
        GetTempPath MAX_PATH, StrPtr(sTemp)
        sTemp = RTrimZ(sTemp)
        If CreatePath(sTemp & "\ZipS\") Then
            CreateTempDir = sTemp & "\ZipS"
        ElseIf CreatePath(AddBackslash(App.Path) & "Temp\") Then
            CreateTempDir = AddBackslash(App.Path) & "Temp"
        End If
    End If
  Exit Function
ErrHandler:
  AlertError "mFilePath.CreateTempDir", LogToFile
End Function

'-----------------------------------------------------------

Public Function AddBackslash(sPath As String) As String
    If Right$(sPath, 1&) = DIR_SEP Then
        AddBackslash = sPath
    Else
        AddBackslash = sPath & DIR_SEP
    End If
End Function

'-----------------------------------------------------------

Public Function NormalizePath(sPath As String) As String
    Dim idx As Long
    idx = Len(sPath)
    If Right$(sPath, 1&) = "\" Then idx = idx - 1&
    NormalizePath = PrettyPath(Left$(sPath, idx))
End Function

'-----------------------------------------------------------

Public Function PrettyPath(sPath As String) As String
    Dim sBuff As String
    sBuff = FillNulls(MAX_PATH) ' Fails on non-existing path
    If ShortPathName(StrPtr(UCase$(sPath)), StrPtr(sBuff), MAX_PATH) = 0& Then
        Mid$(sBuff, 1&) = sPath
    End If
    LongPathName StrPtr(sBuff), StrPtr(sBuff), MAX_PATH
    PrettyPath = RTrimZ(sBuff) 'TrimNulls(sBuff)
End Function

'-----------------------------------------------------------
' Creates the specified file sFileSpec.
' Returns: 2 if created, 1 if existed, 0 if error.
'-----------------------------------------------------------
Public Function CreateFile(sFileSpec As String) As Long
    Dim iFile As Integer

    On Error GoTo FailedCreateFile
    If PathExists(sFileSpec) Then
        CreateFile = 1&
    Else
        If CreatePath(sFileSpec) Then
            iFile = FreeFile()
            Open sFileSpec For Output As #iFile
            Close #iFile
            CreateFile = 2&
    End If: End If
    Exit Function

FailedCreateFile:
    CreateFile = 0&
End Function

'-----------------------------------------------------------
' Creates the specified path if it doesn't already exist.

' IMPORTANT: The specified path must contain a trailing
' backslash character, and can contain an optional folder
' or filename after the last backslash character which is
' ignored.

' Returns: 2 if created, 1 if existed, 0 if error.
'-----------------------------------------------------------
Public Function CreatePath(sPath As String) As Long
    Dim sTemp As String, idx As Long

    On Error GoTo FailedCreatePath
    If PathExists(sPath) Then
        CreatePath = 1&
    Else
        ' Set idx to the first backslash
        idx = InStr(1&, sPath, DIR_SEP)

        Do ' Loop and make each subdir of the path separately
            idx = InStr(idx + 1&, sPath, DIR_SEP)
            If (idx) Then
                sTemp = Left$(sPath, idx - 1&)
                ' Determine if this directory already exists
                If PathExists(sTemp) Then
                    CreatePath = 1&
                Else
                    ' We must create this directory
                    MkDir sTemp
                    CreatePath = 2&
                End If
            End If
        Loop Until idx = 0&
    End If
    Exit Function

FailedCreatePath:
    CreatePath = 0&
End Function

'-----------------------------------------------------------
' Kill Folder will remove all sub-folders and files and
' then optionally delete the specified folder.

' I found when removing all the files in the temp folder
' that some locked files would fail and cause it to not
' continue with the rest of the files.

' This function will continue to remove all unlocked files,
' even after finding locked files. However, if locked files
' are found, the parent folder will also not get removed.
'-----------------------------------------------------------
Public Function KillFolder(sSpec As String, Optional ByVal bJustEmptyDontRemove As Boolean) As Boolean
  Dim sRoot As String, sDir As String, sFile As String
  Dim iCnt As Long, iIdx As Long
  
  If Not FolderExists(sSpec) Then Exit Function
  
  ' Add trailing backslash if missing
  sRoot = AddBackslash(sSpec)
  iCnt = 2& '.' '..'
  
  On Error Resume Next ' Ignore file errors
  sFile = Dir$(sRoot & "*.*", vbNormal)
  Do While LenB(sFile)
     SetAttributes StrPtr(sRoot & sFile), vbNormal
     Kill sRoot & sFile
     sFile = Dir$
  Loop
  
  On Error GoTo HandleIt ' No error should occur in here
  Do: sDir = Dir$(sRoot & "*", vbDirectory)
     For iIdx = 1& To iCnt
        sDir = Dir$ '.' '..' ['fail']
     Next
     If LenB(sDir) = 0& Then Exit Do
     If KillFolder(sRoot & sDir & DIR_SEP) Then
     ' Sub-folder is now gone but Dir$ was reset
     ' during recursive call so Do Dir$(..) again
     Else: iCnt = iCnt + 1&
     ' Kill folder failed (remnant files) so skip
     ' this folder (iCnt + 1) to get the rest
     End If
  Loop
  
  If bJustEmptyDontRemove = False Then RmDir sRoot ' Errors here if remnants
HandleIt:
  KillFolder = Not FolderExists(sSpec)
End Function

'------------------------------------------------------------------
' To specify multiple file names you need to have a magic wand!
' This function returns True if no errors were encounted.
'------------------------------------------------------------------
Public Function RenameFiles(sOldName As String, sNewName As String, Optional ByVal fUndoEnable As Boolean, Optional fRenamingOccurred As Boolean) As Boolean
    Dim fos As SHFILEOPSTRUCT, rc As Long 'nm As SHNAMEMAPPING
    Dim bufB() As Byte, LenTyp As Long, Flags As Integer

    LenTyp = LenB(fos)
    ReDim bufB(1 To LenTyp) ' VB's double word alignment fix

    'SH |...|...|...|...|.|...|...|   30 bytes
    'VB |...|...|...|...|.|>|...|...| 32 bytes

    On Error GoTo RenameFilesError
    Flags = FOF_RENAMEONCOLLISION Or FOF_WANTMAPPINGHANDLE
    If fUndoEnable Then Flags = Flags Or FOF_ALLOWUNDO

    fos.pFrom = sOldName & vbNullChar
    fos.pTo = sNewName & vbNullChar
    fos.fFlags = Flags
    fos.wFunc = FO_RENAME

    ' Copy the SHFILEOPSTRUCT structure into the byte array
    CopyFileOp VarPtr(bufB(1)), VarPtr(fos), LenTyp

    ' Move the last 12 bytes up 2 to correctly align the data
    CopyFileOp VarPtr(bufB(19)), VarPtr(bufB(21)), 12&
    bufB(31) = 0: bufB(32) = 0

    rc = SHFileOperationW(VarPtr(bufB(1)))

    ' Move the last 12 bytes back 2 to align the data for VB
    CopyFileOp VarPtr(bufB(21)), VarPtr(bufB(19)), 12&
    bufB(19) = 0: bufB(20) = 0
    CopyFileOp VarPtr(fos), VarPtr(bufB(1)), LenTyp

    If Not fos.hNameMappings = 0& Then ' Collision renaming occurred
        ' fos.hNameMappings is a Handle to a file name mapping object
        ' that contains an array of SHNAMEMAPPING structures.
        ' Each structure contains the old and new path names for each
        ' file that was moved, copied, or renamed. This member is used
        ' only if fFlags includes FOF_WANTMAPPINGHANDLE.
        ' The handle must be freed by using SHFreeNameMappings.
        SHFreeNameMappings fos.hNameMappings

        fRenamingOccurred = True
    End If

    RenameFiles = (rc = 0&)
RenameFilesError:
End Function

'-------------------------------------------------------------------
' To specify multiple source files they must be separated by the NUL
' character (Chr$(0) or vbNullChar). Wildcard characters are allowed.
' This function returns True if no errors were encounted.
'-------------------------------------------------------------------
Public Function CopyFiles(sSource As String, sDestination As String, Optional ByVal fUndoEnable As Boolean, Optional sCaption As String, Optional fRenamingOccurred As Boolean) As Boolean
    Dim fos As SHFILEOPSTRUCT, rc As Long 'nm As SHNAMEMAPPING
    Dim bufB() As Byte, LenTyp As Long, Flags As Integer

    LenTyp = LenB(fos)
    ReDim bufB(1 To LenTyp) ' VB's double word alignment fix

    'SH |...|...|...|...|.|...|...|   30 bytes
    'VB |...|...|...|...|.|>|...|...| 32 bytes

    On Error GoTo CopyFilesError
    Flags = FOF_NOCONFIRMMKDIR Or FOF_RENAMEONCOLLISION Or FOF_WANTMAPPINGHANDLE
    If fUndoEnable Then Flags = Flags Or FOF_ALLOWUNDO

    If LenB(sCaption) Then
        Flags = Flags Or FOF_SIMPLEPROGRESS
        fos.lpszProgressTitle = sCaption & vbNullChar
    End If

    fos.pFrom = sSource & vbNullChar
    fos.pTo = sDestination & vbNullChar
    fos.fFlags = Flags
    fos.wFunc = FO_COPY

    ' Copy the SHFILEOPSTRUCT structure into the byte array
    CopyFileOp VarPtr(bufB(1)), VarPtr(fos), LenTyp

    ' Move the last 12 bytes up 2 to correctly align the data
    CopyFileOp VarPtr(bufB(19)), VarPtr(bufB(21)), 12&
    bufB(31) = 0: bufB(32) = 0

    rc = SHFileOperationW(VarPtr(bufB(1)))

    ' Move the last 12 bytes back 2 to align the data for VB
    CopyFileOp VarPtr(bufB(21)), VarPtr(bufB(19)), 12&
    bufB(19) = 0: bufB(20) = 0
    CopyFileOp VarPtr(fos), VarPtr(bufB(1)), LenTyp

    If Not fos.hNameMappings = 0& Then ' Collision renaming occurred
        ' fos.hNameMappings is a Handle to a file name mapping object
        ' that contains an array of SHNAMEMAPPING structures.
        ' Each structure contains the old and new path names for each
        ' file that was moved, copied, or renamed. This member is used
        ' only if fFlags includes FOF_WANTMAPPINGHANDLE.
        ' The handle must be freed by using SHFreeNameMappings.
        SHFreeNameMappings fos.hNameMappings

        fRenamingOccurred = True
    End If

    CopyFiles = (rc = 0&)
CopyFilesError:
End Function

'-------------------------------------------------------------------
' To specify multiple source files they must be separated by the NUL
' character (Chr$(0) or vbNullChar). Wildcard characters are allowed.
' This function returns True if no errors were encounted.
'-------------------------------------------------------------------
Public Function MoveFiles(sSource As String, sDestination As String, Optional ByVal fUndoEnable As Boolean, Optional sCaption As String, Optional fRenamingOccurred As Boolean) As Boolean
    Dim fos As SHFILEOPSTRUCT, rc As Long 'nm As SHNAMEMAPPING
    Dim bufB() As Byte, LenTyp As Long, Flags As Integer

    LenTyp = LenB(fos)
    ReDim bufB(1 To LenTyp) ' VB's double word alignment fix

    'SH |...|...|...|...|.|...|...|   30 bytes
    'VB |...|...|...|...|.|>|...|...| 32 bytes

    On Error GoTo MoveFilesError
    Flags = FOF_NOCONFIRMMKDIR Or FOF_RENAMEONCOLLISION Or FOF_WANTMAPPINGHANDLE
    If fUndoEnable Then Flags = Flags Or FOF_ALLOWUNDO

    If LenB(sCaption) Then
        Flags = Flags Or FOF_SIMPLEPROGRESS
        fos.lpszProgressTitle = sCaption & vbNullChar
    End If

    fos.pFrom = sSource & vbNullChar
    fos.pTo = sDestination & vbNullChar
    fos.fFlags = Flags
    fos.wFunc = FO_MOVE

    ' Copy the SHFILEOPSTRUCT structure into the byte array
    CopyFileOp VarPtr(bufB(1)), VarPtr(fos), LenTyp

    ' Move the last 12 bytes up 2 to correctly align the data
    CopyFileOp VarPtr(bufB(19)), VarPtr(bufB(21)), 12&
    bufB(31) = 0: bufB(32) = 0

    rc = SHFileOperationW(VarPtr(bufB(1)))

    ' Move the last 12 bytes back 2 to align the data for VB
    CopyFileOp VarPtr(bufB(21)), VarPtr(bufB(19)), 12&
    bufB(19) = 0: bufB(20) = 0
    CopyFileOp VarPtr(fos), VarPtr(bufB(1)), LenTyp

    If Not fos.hNameMappings = 0& Then ' Collision renaming occurred
        ' fos.hNameMappings is a Handle to a file name mapping object
        ' that contains an array of SHNAMEMAPPING structures.
        ' Each structure contains the old and new path names for each
        ' file that was moved, copied, or renamed. This member is used
        ' only if fFlags includes FOF_WANTMAPPINGHANDLE.
        ' The handle must be freed by using SHFreeNameMappings.
        SHFreeNameMappings fos.hNameMappings
        
        fRenamingOccurred = True
    End If

    MoveFiles = (rc = 0&)
MoveFilesError:
End Function

'-------------------------------------------------------------------
' Copies source to destination without confirmation if dest exists.
' This function returns True if no errors were encounted.
'-------------------------------------------------------------------
Public Function UpdateFile(sSource As String, sDestination As String) As Boolean
    Dim fos As SHFILEOPSTRUCT, rc As Long

    On Error GoTo UpdateFileError

    fos.pFrom = sSource & vbNullChar
    fos.pTo = sDestination & vbNullChar
    fos.fFlags = FOF_NOCONFIRMATION
    fos.wFunc = FO_COPY

    rc = SHFileOperationW(VarPtr(fos))

    UpdateFile = (rc = 0&)
UpdateFileError:
End Function

'----------------------------------------------------------------------
' To specify multiple files to delete they must be separated by the NUL
' character (Chr$(0) or vbNullChar). Wildcard characters are allowed.
' This function returns True if no errors were encounted.
'----------------------------------------------------------------------
Public Function DeleteFiles(sSpec As String, Optional ByVal ToRecycleBin As Boolean = True) As Boolean
    Dim fos As SHFILEOPSTRUCT, rc As Long, Flags As Integer

    On Error GoTo DeleteFilesError
    If ToRecycleBin Then Flags = FOF_ALLOWUNDO

    fos.pFrom = sSpec & vbNullChar
    fos.fFlags = Flags
    fos.wFunc = FO_DELETE
    rc = SHFileOperationW(VarPtr(fos))

    DeleteFiles = (rc = 0&)
DeleteFilesError:
End Function
