/ Snippet Library - View Code

Visual Basic / File & Disk Operations / ModFile.bas

Snippet details

ID: 328

Viewed: 1346

Added: 2002-08-19

Version:

Snippets in this catagory
Show Printable Version

used in conjunction with file routines

General Details

Snippet uploaded by: snippet

Email : webmaster@snippetlibrary.com

Snippet By: Unknown

Snippet By:	Unknown
Declarations
Highlight All'Everything goes into a module.
Code
Highlight AllOption Explicit ' modFiles.bas '------------------------------------------------------------- ' Summary of contained methods: '------------------------------------------------------------- ' GetWindowsPath() ' GetSystemPath() ' FixPath() ' GetTempFilename() ' FileExtension() ' FilePath() ' FileName() ' ShortPath() ' DriveExists() ' FileExists() ' FileList() ' CopyFiles() ' MoveFiles() ' RenameFiles() ' DeleteFiles() '------------------------------------------------------------- ' API Constant Declarations '------------------------------------------------------------- Private Const MAX_PATH = 260 Private Const INVALID_HANDLE_VALUE = -1 Private Const FO_MOVE = &H1 Private Const FO_COPY = &H2 Private Const FO_DELETE = &H3 Private Const FO_RENAME = &H4 Private Const FOF_SILENT = &H4 Private Const FOF_RENAMEONCOLLISION = &H8 Private Const FOF_NOCONFIRMATION = &H10 Private Const FOF_SIMPLEPROGRESS = &H100 Private Const FOF_ALLOWUNDO = &H40 '------------------------------------------------------------- ' API Structure Declarations '------------------------------------------------------------- Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAborted As Boolean hNameMaps As Long sProgress As String End Type '------------------------------------------------------------- ' API Function Declarations '------------------------------------------------------------- Private Declare Function SHFileOperation Lib "shell32.dll" _ Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Private Declare Function FindFirstFileA Lib "kernel32" _ (ByVal lpFileName As String, _ lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFileA Lib "kernel32" _ (ByVal hFindFile As Long, _ lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" _ (ByVal hFindFile As Long) As Long Private Declare Function GetLogicalDrives Lib "kernel32" _ () As Long Private Declare Function GetShortPathNameA Lib "kernel32" _ (ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, _ ByVal cchBuffer As Long) As Long Private Declare Function GetTempFileNameA Lib "kernel32" _ (ByVal lpszPath As String, _ ByVal lpPrefixString As String, _ ByVal wUnique As Long, _ ByVal lpTempFileName As String) As Long Private Declare Function GetTempPathA Lib "kernel32" _ (ByVal nBufferLength As Long, _ ByVal lpBuffer As String) As Long Private Declare Function GetWindowsDirectoryA Lib "kernel32" _ (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetSystemDirectoryA Lib "kernel32" _ (ByVal lpBuffer As String, ByVal nSize As Long) As Long ' ' Public Function GetWindowsPath() As String '------------------------------------------------------------- ' Returns the path to the Windows folder. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' MAX_PATH = 260 ' ' Private Declare Function GetWindowsDirectoryA Lib "kernel32" _ ' (ByVal lpBuffer As String, ByVal nSize As Long) As Long '------------------------------------------------------------- Dim sBuffer As String Dim r As Long ' sBuffer = Space$(MAX_PATH) r = GetWindowsDirectoryA(sBuffer, MAX_PATH) If r Then GetWindowsPath = Left$(sBuffer, r - 1&) End If ' End Function Private Function GetSystemPath() As String '------------------------------------------------------------- ' Returns the path to the Windows System folder. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' MAX_PATH = 260 ' ' Private Declare Function GetSystemDirectoryA Lib "kernel32" _ ' (ByVal lpBuffer As String, ByVal nSize As Long) As Long '------------------------------------------------------------- Dim sBuffer As String Dim r As Long sBuffer = Space$(MAX_PATH) r = GetSystemDirectoryA(sBuffer, MAX_PATH) If r Then GetSystemPath = Left$(sBuffer, r - 1&) End If End Function Public Function FixPath(ByVal sPath As String) As String '------------------------------------------------------------- ' Assures that a path ends with "". '------------------------------------------------------------- If Right$(sPath, 1) <> "" Then FixPath = sPath & "" Else FixPath = sPath End If End Function Public Function GetTempFilename(Optional sPrefix As String) As String '------------------------------------------------------------- ' Creates a temporary file with a unique name in the ' Windows temporary folder. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' MAX_PATH = 260 ' ' Private Declare Function GetTempFileNameA Lib "kernel32" _ ' (ByVal lpszPath As String, _ ' ByVal lpPrefixString As String, _ ' ByVal wUnique As Long, _ ' ByVal lpTempFileName As String) As Long ' Private Declare Function GetTempPathA Lib "kernel32" _ ' (ByVal nBufferLength As Long, _ ' ByVal lpBuffer As String) As Long '------------------------------------------------------------- Dim r As Long Dim sTempFile As String Dim sTempDir As String sTempDir = Space$(MAX_PATH) r = GetTempPathA(MAX_PATH, sTempDir) If r Then sTempDir = Left$(sTempDir, r - 1&) If Len(sPrefix) = 0 Then sPrefix = "tmp" End If sTempFile = Space$(MAX_PATH) r = GetTempFileNameA(sTempDir, sPrefix, 0&, sTempFile) If r Then GetTempFilename = Left$(sTempFile, r - 1&) End If End If End Function Public Function FileExtension(ByVal sFile As String) As String '------------------------------------------------------------- ' Extracts the extension from a filename is present. '------------------------------------------------------------- Dim i As Integer i = InStrRev(sFile, ".") If i > 0 Then FileExtension = Mid$(sFile, i + 1) End If End Function Public Function FilePath(ByVal sFile As String) As String '------------------------------------------------------------- ' Extracts the path from a fully-qualified filename. '------------------------------------------------------------- Dim i As Integer i = InStrRev(sFile, "") If i > 0 Then FilePath = Left$(sFile, i) End If End Function Public Function FileName(ByVal sFullPath As String) As String '------------------------------------------------------------- ' Extracts the filename from a fully-qualified path. '------------------------------------------------------------- Dim i As Integer i = InStrRev(sFullPath, "") If i > 0 Then FileName = Mid$(sFullPath, i + 1) Else FileName = sFullPath End If End Function Public Function ShortPath(ByVal LongName As String) As String '------------------------------------------------------------- ' Returns the short (8.3) filename for a given file or path. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' MAX_PATH = 260 ' ' Private Declare Function GetShortPathNameA Lib "kernel32" _ ' (ByVal lpszLongPath As String, _ ' ByVal lpszShortPath As String, _ ' ByVal cchBuffer As Long) As Long '------------------------------------------------------------- Dim r As Long Dim sBuffer As String sBuffer = Space$(MAX_PATH) r = GetShortPathNameA(LongName, sBuffer, MAX_PATH) If r Then ShortPath = Left$(sBuffer, r - 1&) End If End Function Public Function DriveExists(ByVal sDriveLetter As String) As Boolean '------------------------------------------------------------- ' Determines whether a drive exists. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' Private Declare Function GetLogicalDrives Lib "kernel32" _ ' () As Long '------------------------------------------------------------- Dim dwDrives As Long Dim Mask As Long dwDrives = GetLogicalDrives() Mask = 2 ^ (Asc(UCase$(sDriveLetter)) - 65) DriveExists = ((dwDrives And Mask) = Mask) End Function Public Function FileList(ByVal sPath As String, _ ByRef saFileList() As String, _ Optional ByVal sFileSpec As String = "") As Long '------------------------------------------------------------- ' Files saFileList() with a list of all files and folders ' in a given path. Returns the number of files. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' Private Const MAX_PATH = 260 ' Private Const INVALID_HANDLE_VALUE = -1 ' ' Private Type FILETIME ' dwLowDateTime As Long ' dwHighDateTime As Long ' End Type ' Private Type WIN32_FIND_DATA ' dwFileAttributes As Long ' ftCreationTime As FILETIME ' ftLastAccessTime As FILETIME ' ftLastWriteTime As FILETIME ' nFileSizeHigh As Long ' nFileSizeLow As Long ' dwReserved0 As Long ' dwReserved1 As Long ' cFileName As String MAX_PATH ' cAlternate As String * 14 ' End Type ' ' Private Declare Function FindNextFileA Lib "kernel32" _ ' (ByVal hFindFile As Long, _ ' lpFindFileData As WIN32_FIND_DATA) As Long ' ' Private Declare Function FindFirstFileA Lib "kernel32" _ ' (ByVal lpFileName As String, _ ' lpFindFileData As WIN32_FIND_DATA) As Long ' ' Private Declare Function FindClose Lib "kernel32" _ ' (ByVal hFindFile As Long) As Long '------------------------------------------------------------- Dim iCnt As Long Dim iMax As Long Dim uFIND_DATA As WIN32_FIND_DATA Dim r As Long Dim hFind As Long Dim sName As String If Right$(sPath, 1) <> "" Then sPath = sPath & "" End If sPath = sPath & sFileSpec iMax = 49 ReDim saFileList(iMax) hFind = FindFirstFileA(sPath, uFIND_DATA) If Not hFind = INVALID_HANDLE_VALUE Then sName = uFIND_DATA.cFileName If InStr(sName, Chr$(0)) Then sName = Left$(sName, InStr(sName, Chr$(0)) - 1&) If Not sName = "." Then If Not sName = ".." Then saFileList(0) = sName iCnt = 1& End If End If End If r = FindNextFileA(hFind, uFIND_DATA) Do Until r = 0& sName = uFIND_DATA.cFileName If InStr(sName, Chr$(0)) Then sName = Left$(sName, InStr(sName, Chr$(0)) - 1&) End If If Not sName = "." Then If Not sName = ".." Then iCnt = iCnt + 1& If iCnt >= iMax Then iMax = iMax + 50 ReDim Preserve saFileList(iMax) End If saFileList(iCnt - 1&) = sName End If End If r = FindNextFileA(hFind, uFIND_DATA) Loop r = FindClose(hFind) End If If iCnt = 0& Then Erase saFileList() Else ReDim Preserve saFileList(iCnt - 1&) End If FileList = iCnt End Function Public Function FileExists(ByVal sFile As String) As Boolean '------------------------------------------------------------- ' Determines whether a file or path exists. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' Private Const MAX_PATH = 260 ' Private Const INVALID_HANDLE_VALUE = -1 ' ' Private Type FILETIME ' dwLowDateTime As Long ' dwHighDateTime As Long ' End Type ' Private Type WIN32_FIND_DATA ' dwFileAttributes As Long ' ftCreationTime As FILETIME ' ftLastAccessTime As FILETIME ' ftLastWriteTime As FILETIME ' nFileSizeHigh As Long ' nFileSizeLow As Long ' dwReserved0 As Long ' dwReserved1 As Long ' cFileName As String * MAX_PATH ' cAlternate As String * 14 ' End Type ' ' Private Declare Function FindFirstFileA Lib "kernel32" _ ' (ByVal lpFileName As String, _ ' lpFindFileData As WIN32_FIND_DATA) As Long ' ' Private Declare Function FindClose Lib "kernel32" _ ' (ByVal hFindFile As Long) As Long '------------------------------------------------------------- Dim r As Long Dim uFIND_DATA As WIN32_FIND_DATA r = FindFirstFileA(sFile, uFIND_DATA) If r = INVALID_HANDLE_VALUE Then FileExists = False Else FileExists = True Call FindClose(r) End If End Function Public Function CopyFiles( _ FileNames As Variant, MoveTo As String, _ Optional ShowConfirmation As Boolean = True, _ Optional HideProgress As Boolean = False, _ Optional RenameOnCollision As Boolean = False) As Boolean '------------------------------------------------------------- ' Copies the specifed files to a new location. The user can ' pass in either a single filename or an array of filenames. '------------------------------------------------------------- ' Depends on: ' CopyMoveFiles() '------------------------------------------------------------- CopyFiles = CopyMoveFiles(FO_COPY, FileNames, MoveTo, _ ShowConfirmation, HideProgress, RenameOnCollision) End Function Public Function RenameFiles( _ SrcFile As String, DestFile As String, _ Optional ShowConfirmation As Boolean = True, _ Optional RenameOnCollision As Boolean = False) As Boolean '------------------------------------------------------------- ' Renames the specifed file. '------------------------------------------------------------- ' Depends on: ' CopyMoveFiles() '------------------------------------------------------------- RenameFiles = CopyMoveFiles(FO_RENAME, SrcFile, DestFile, _ ShowConfirmation, False, RenameOnCollision) End Function Public Function MoveFiles(FileNames As Variant, _ MoveTo As String, _ Optional ShowConfirmation As Boolean = True, _ Optional HideProgress As Boolean = False, _ Optional RenameOnCollision As Boolean = False) As Boolean '------------------------------------------------------------- ' Moves the specifed files to a new location. The user can ' pass in either a single filename or an array of filenames. '------------------------------------------------------------- ' Depends on: ' CopyMoveFiles() '------------------------------------------------------------- MoveFiles = CopyMoveFiles(FO_MOVE, FileNames, MoveTo, _ ShowConfirmation, HideProgress, RenameOnCollision) End Function Private Function CopyMoveFiles( _ Operation As Integer, _ FileNames As Variant, _ MoveTo As String, _ ShowConfirmation As Boolean, _ HideProgress As Boolean, _ RenameOnCollision As Boolean) As Boolean '------------------------------------------------------------- ' Copies/moves/renames the specifed files. The user can ' pass in either a single filename or an array of filenames. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' Private Const FOF_ALLOWUNDO = &H40 ' Private Const FOF_NOCONFIRMATION = &H10 ' Private Const FOF_SILENT = &H4 ' ' Private Const FO_DELETE = &H3 ' ' Private Type SHFILEOPSTRUCT ' hwnd As Long ' wFunc As Long ' pFrom As String ' pTo As String ' fFlags As Integer ' fAborted As Boolean ' hNameMaps As Long ' sProgress As String ' End Type ' ' Private Declare Function SHFileOperation Lib _ ' "shell32.dll" Alias "SHFileOperationA" _ ' (lpFileOp As SHFILEOPSTRUCT) As Long '------------------------------------------------------------- Dim r As Long Dim i As Integer Dim sOrig As String Dim SHFileOp As SHFILEOPSTRUCT If IsArray(FileNames) Then For i = LBound(FileNames) To UBound(FileNames) sOrig = sOrig & FileNames(i) & Chr$(0) Next i Else sOrig = FileNames & Chr$(0) End If With SHFileOp .wFunc = Operation .pFrom = sOrig .pTo = MoveTo If Not ShowConfirmation Then .fFlags = FOF_NOCONFIRMATION End If If HideProgress Then .fFlags = .fFlags Or FOF_SILENT End If If RenameOnCollision Then .fFlags = .fFlags Or FOF_RENAMEONCOLLISION End If End With r = SHFileOperation(SHFileOp) If r = 0 Then CopyMoveFiles = Not SHFileOp.fAborted Else CopyMoveFiles = False End If End Function Public Function DeleteFiles(FileNames As Variant, _ Optional MoveToRecycle As Boolean = False, _ Optional ShowConfirmation As Boolean = True, _ Optional HideProgress As Boolean = False) As Long '------------------------------------------------------------- ' Deletes the specifed files. The user can ' pass in either a single filename or an array of filenames. '------------------------------------------------------------- ' API Declarations: '------------------------------------------------------------- ' Private Const FOF_ALLOWUNDO = &H40 ' Private Const FOF_NOCONFIRMATION = &H10 ' Private Const FOF_SILENT = &H4 ' ' Private Const FO_DELETE = &H3 ' ' Private Type SHFILEOPSTRUCT ' hwnd As Long ' wFunc As Long ' pFrom As String ' pTo As String ' fFlags As Integer ' fAborted As Boolean ' hNameMaps As Long ' sProgress As String ' End Type ' ' Private Declare Function SHFileOperation Lib _ ' "shell32.dll" Alias "SHFileOperationA" _ ' (lpFileOp As SHFILEOPSTRUCT) As Long '------------------------------------------------------------- Dim sDest As String Dim i As Integer Dim SHFileOp As SHFILEOPSTRUCT Dim r As Long With SHFileOp If MoveToRecycle Then .fFlags = FOF_ALLOWUNDO End If If Not ShowConfirmation Then .fFlags = .fFlags Or FOF_NOCONFIRMATION End If If HideProgress Then .fFlags = .fFlags Or FOF_SILENT End If End With If IsArray(FileNames) Then For i = LBound(FileNames) To UBound(FileNames) sDest = sDest & FileNames(i) & Chr$(0) Next i Else sDest = FileNames & Chr$(0) End If With SHFileOp .wFunc = FO_DELETE .pFrom = sDest End With r = SHFileOperation(SHFileOp) If r <> 0 Then DeleteFiles = False Else DeleteFiles = Not SHFileOp.fAborted End If End Function

No Reviews to show