vbAccelerator - Contents of code file: FileTool.bas
Attribute VB_Name = "FileTool"
Option Explicit
' Code by Bruce McKinney, from book 'Hardcode Visual Basic'
' with some enhancements by Robert Heinig.
'
' Please refer to http://www.pobox.com/HardcoreVB for information
' on licensing and redistribution of this code.
Public Enum EErrorFileTool
eeBaseFileTool = 13480 ' FileTool
End Enum
Public Enum EWalkModeFile
ewmfDirs = &H20
ewmfFiles = &H40
ewmfBoth = &H20 Or &H40
End Enum
' Use Declare instead of type library because of Strings in UDT
Private Declare Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
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
fAnyOperationsAbortedLo As Integer ' Indicates partial failure
fAnyOperationsAbortedHi As Integer
hNameMappingsLo As Long ' Array indicating each success
hNameMappingsHi As Long
lpszProgressTitleLo As Long ' Title for progress dialog
lpszProgressTitleHi As Long
End Type
Const datMin As Date = #1/1/100#
Const datMax As Date = #12/31/9999 11:59:59 PM#
' Difference between day zero for VB dates and Win32 dates
' (or #12-30-1899# - #01-01-1601#)
Const rDayZeroBias As Double = 109205# ' Abs(CDbl(#01-01-1601#))
' 10000000 nanoseconds * 60 seconds * 60 minutes * 24 hours / 10000
' comes to 86400000 (the 10000 adjusts for fixed point in Currency)
Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#
'Public Function Win32ToVbTime(ft As Currency) As Date
' Dim ftl As Currency
' ' Call API to convert from UTC time to local time
' If FileTimeToLocalFileTime(ft, ftl) Then
' ' Local time is nanoseconds since 01-01-1601
' ' In Currency that comes out as milliseconds
' ' Divide by milliseconds per day to get days since 1601
' ' Subtract days from 1601 to 1899 to get VB Date equivalent
' Win32ToVbTime = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)
' Else
' ApiRaise Err.LastDllError
' End If
'End Function
'
'Public Function VbToWin32Time(dat As Date) As Currency
' Dim ftl As Currency
' ' Date is days since 1899
' ' Add days from 1601 to 1899 to get Win32 days
' ' Multiply by milliseconds per day to get milliseconds since 1601
' ' That would be nanoseconds if it weren't in Currency
' ftl = CCur((CDbl(dat) + rDayZeroBias) * rMillisecondPerDay)
' ' Call API to convert from local time to UTC time
' If LocalFileTimeToFileTime(ftl, VbToWin32Time) = 0 Then
' ApiRaise Err.LastDllError
' End If
'End Function
'
'Public Function FileAnyDateTime(sPath As String, _
' Optional datCreation As Date = datMin, _
' Optional datAccess As Date = datMin) As Date
' ' Take the easy way if no optional arguments
' If datCreation = datMin And datAccess = datMin Then
' FileAnyDateTime = VBA.FileDateTime(sPath)
' Exit Function
' End If
'
' Dim fnd As WIN32_FIND_DATA
' Dim ftCreate As FILETIME, ftAccess As FILETIME, ftModify As FILETIME
' Dim hFind As Long, f As Boolean, stime As SYSTEMTIME
' ' Get all three times in UDT
' hFind = FindFirstFile(sPath, fnd)
' If hFind = hInvalid Then ApiRaise Err.LastDllError
' FindClose hFind
' ' Convert them to Visual Basic format
' datCreation = Win32ToVbTime(fnd.ftCreationTime)
' datAccess = Win32ToVbTime(fnd.ftLastAccessTime)
' FileAnyDateTime = Win32ToVbTime(fnd.ftLastWriteTime)
'End Function
'
'Public Sub ReplaceFile(sOld As String, sTmp As String)
' Dim fnd As WIN32_FIND_DATA, hFind As Long, hOld As Long, f As Boolean
' ' Get file time and attributes of old file
' hFind = FindFirstFile(sOld, fnd)
' If hFind = hInvalid Then ApiRaise Err.LastDllError
' ' Replace by deleting old and renaming new to old
' Kill sOld
' Name sTmp As sOld
' ' Assign old attributes and time to new file
' hOld = lopen(sOld, OF_WRITE Or OF_SHARE_DENY_WRITE)
' If hOld = hInvalid Then ApiRaise Err.LastDllError
' f = SetFileTime(hOld, fnd.ftCreationTime, _
' fnd.ftLastAccessTime, fnd.ftLastWriteTime)
' If f = 0 Then ApiRaise Err.LastDllError
' lclose hOld
' f = SetFileAttributes(sOld, fnd.dwFileAttributes)
' If f = 0 Then ApiRaise Err.LastDllError
'End Sub
'' Better version of FileCopy (CopyAnyFile) and matching MoveAnyFile,
'' DeleteAnyFile, and RenameAnyFile
'
'Public Function CopyAnyFile(sSrc As String, sDst As String, _
' Optional Options As Long = 0, _
' Optional Owner As Long = hNull) As Boolean
' If HasShell Then
' Dim fo As SHFILEOPSTRUCT, f As Long
' fo.wFunc = FO_COPY
' ' Make sure all strings are double-null-terminated as required
' fo.pFrom = sSrc & vbNullChar
' fo.pTo = sDst & vbNullChar
' fo.fFlags = Options
' fo.hWnd = Owner
' ' Mask out invalid flags
' fo.fFlags = fo.fFlags And FOF_COPYFLAGS
' f = SHFileOperation(fo)
' CopyAnyFile = (f = 0)
' Else
' ' For Windows NT 3.51
' On Error Resume Next
' ' FileCopy expects full name of destination file
' FileCopy sSrc, sDst
' If Err Then
' Err = 0
' ' CopyAnyFile can handle destination directory
' sDst = NormalizePath(sDst) & _
' GetFileBaseExt(sSrc)
' FileCopy sSrc, sDst
' End If
' ' Enhance further to emulate SHFileOperation options
' ' such as validation and wild cards
' CopyAnyFile = (Err = 0)
' End If
'End Function
'
'Public Function MoveAnyFile(sSrc As String, sDst As String, _
' Optional afOptions As Long = 0, _
' Optional Owner As Long = hNull) As Boolean
' If HasShell Then
' Dim fo As SHFILEOPSTRUCT, f As Long
' fo.wFunc = FO_MOVE
' ' Make sure all strings are double-null-terminated as required
' fo.pFrom = sSrc & vbNullChar
' fo.pTo = sDst & vbNullChar
' fo.fFlags = afOptions
' fo.hWnd = Owner
' ' Mask out invalid flags
' fo.fFlags = fo.fFlags And FOF_COPYFLAGS
' f = SHFileOperation(fo)
' MoveAnyFile = (f = 0)
' Else
' ' Windows NT 3.51
' On Error Resume Next
' ' Name actually moves files, contrary to documentation
' Name sSrc As sDst
' If Err Then ' Probably you gave directory destination
' Err = 0
' sDst = NormalizePath(sDst) & _
' GetFileBaseExt(sSrc)
' Name sSrc As sDst
' End If
' ' Enhance further to emulate SHFileOperation options
' ' such as validation and wild cards
' MoveAnyFile = (Err = 0)
' End If
'End Function
'
'Public Function RenameAnyFile(sSrc As String, sDst As String, _
' Optional Options As Long = 0, _
' Optional Owner As Long = hNull) As Boolean
' If HasShell Then
' Dim fo As SHFILEOPSTRUCT, f As Long
' ' Make sure all strings are double-null-terminated as required
' fo.wFunc = FO_RENAME
' fo.pFrom = sSrc & vbNullChar
' fo.pTo = sDst & vbNullChar
' fo.fFlags = Options
' fo.hWnd = Owner
' ' Mask out invalid flags
' fo.fFlags = fo.fFlags And FOF_RENAMEFLAGS
' f = SHFileOperation(fo)
' RenameAnyFile = (f = 0)
' Else
' ' Windows NT 3.51
' On Error Resume Next
' Name sSrc As sDst
' RenameAnyFile = (Err = 0)
' ' Enhance further to emulate SHFileOperation options
' ' such as validation and wild cards
' End If
'End Function
'
'Public Function DeleteAnyFile(sSrc As String, _
' Optional Options As Long = 0, _
' Optional Owner As Long = hNull) As Boolean
' If HasShell Then
' Dim fo As SHFILEOPSTRUCT, f As Long
' fo.wFunc = FO_DELETE
' ' Make sure all strings are double-null-terminated as required
' fo.pFrom = sSrc & vbNullChar
' ' fo.pTo = sNullStr
' fo.fFlags = Options
' fo.hWnd = Owner
' ' Mask out invalid flags
' fo.fFlags = fo.fFlags And FOF_DELETEFLAGS
' f = SHFileOperation(fo)
' DeleteAnyFile = (f = 0)
' Else
' ' Windows NT 3.51
' On Error Resume Next
' Kill sSrc
' DeleteAnyFile = (Err = 0)
' ' Enhance further to emulate SHFileOperation options
' ' such as validation and wild cards
' End If
'End Function
' Make sure path ends in a backslash
Public Function NormalizePath(sPath As String) As String
If Right$(sPath, 1) <> sBSlash Then
NormalizePath = sPath & sBSlash
Else
NormalizePath = sPath
End If
End Function
' Make sure path doesn't end in a backslash
Public Sub DenormalizePath(sPath As String)
' Don't strip paths in form: d:\
If (Mid$(sPath, 2, 2) = ":\") And (Len(sPath) = 3) Then Exit Sub
If Right$(sPath, 1) = sBSlash Then
sPath = Left$(sPath, Len(sPath) - 1)
End If
End Sub
Function GetFileBase(sFile As String) As String
Dim iBase As Long, iExt As Long, s As String
If Len(sFile) = 0 Then Exit Function
s = GetFullPath(sFile, iBase, iExt)
GetFileBase = Mid$(s, iBase, iExt - iBase)
End Function
Function GetFileBaseExt(sFile As String) As String
Dim iBase As Long, s As String
If Len(sFile) = 0 Then Exit Function
s = GetFullPath(sFile, iBase)
GetFileBaseExt = Mid$(s, iBase)
End Function
Function GetFileExt(sFile As String) As String
Dim iExt As Long, s As String
If Len(sFile) = 0 Then Exit Function
s = GetFullPath(sFile, , iExt)
GetFileExt = Mid$(s, iExt)
End Function
Function GetFileDir(sFile As String) As String
Dim iBase As Long, s As String
If Len(sFile) = 0 Then Exit Function
s = GetFullPath(sFile, iBase)
GetFileDir = Left$(s, iBase - 1)
End Function
Function GetFileFullSpec(sFile As String) As String
If Len(sFile) = 0 Then Exit Function
GetFileFullSpec = GetFullPath(sFile)
End Function
' Win32 functions with Basic interface
' GetFullPath - Basic version of Win32 API emulation routine. It returns a
' BSTR, and indexes to the file name, directory, and extension parts of the
' full name.
'
' Input: sFileName - file to be qualified in one of these formats:
'
' [relpath\]file.ext
' \[path\]file.ext
' .\[path\]file.ext
' d:\[path\]file.ext
' ..\[path\]file.ext
' \\server\machine\[path\]file.ext
' iName - variable to receive file name position
' iDir - variable to receive directory position
' iExt - variable to receive extension position
'
' Return: Full path name, or an empty string on failure
'
' Errors: Any of the following:
' ERROR_BUFFER_OVERFLOW = 111
' ERROR_INVALID_DRIVE = 15
' ERROR_CALL_NOT_IMPLEMENTED = 120
' ERROR_BAD_PATHNAME = 161
Public Function GetFullPath(sFileName As String, _
Optional FilePart As Long, _
Optional ExtPart As Long, _
Optional DirPart As Long) As String
Dim c As Long, p As Long, sRet As String
If Len(sFileName) = 0 Then Exit Function
' Get the path size, then create string of that size
sRet = String$(cMaxPath, 0)
c = GetFullPathName(sFileName, cMaxPath, sRet, p)
If c = 0 Then ApiRaise Err.LastDllError
'BugAssert c <= cMaxPath, "GetFullPathName returned bad length"
sRet = Left$(sRet, c)
' Get the directory, file, and extension positions
GetDirExt sRet, FilePart, DirPart, ExtPart
GetFullPath = sRet
End Function
Private Sub GetDirExt(sFull As String, iFilePart As Long, _
iDirPart As Long, iExtPart As Long)
Dim iDrv As Long, i As Long, cMax As Long
Dim fFirst As Boolean
cMax = Len(sFull)
iDrv = Asc(UCase$(Left$(sFull, 1)))
' If in format d:\path\name.ext, return 3
If iDrv <= 90 Then ' Less than Z
If iDrv >= 65 Then ' Greater than A
If Mid$(sFull, 2, 2) = ":\" Then ' Second character is :
iDirPart = 3
End If
End If
Else
' If in format \\machine\share\path\name.ext, return position of \path
' First and second character must be \
If Mid$(sFull, 1, 2) <> "\\" Then ApiRaise ERROR_BAD_PATHNAME
i = InStr(3, sFull, "\")
If i > 0 Then iDirPart = InStr(i + 1, sFull, "\")
End If
' Start from end and find extension
iExtPart = cMax + 1 ' Assume no extension
fFirst = False
Dim sChar As String
For i = cMax To iDirPart Step -1
sChar = Mid$(sFull, i, 1)
If Not fFirst Then
If sChar = "." Then
iExtPart = i
fFirst = True
End If
End If
If sChar = "\" Then
iFilePart = i + 1
Exit For
End If
Next
End Sub
'Public Function ShellAndWaitForTermination( _
' sShell As String, _
' Optional ByVal eWindowStyle As VBA.VbAppWinStyle = vbNormalFocus, _
' Optional ByRef lExitCode As Long, _
' Optional ByVal lTimeOutMilliSecs As Long = 2000000000 _
' ) As Boolean
'
' Dim hProcess As Long
' Dim rc As Long
' Dim lTimeStart As Long
' Dim bSuccess As Boolean
' Dim sApp As String, i As Integer
'
' bSuccess = False
' On Error GoTo ErrTrap
'
' ' Kurzname fr Fehlerbeschreibungen:
' i = InStrRev(sShell, "\")
' If i = 0 Then sApp = sShell Else sApp = Mid$(sShell, i + 1)
' ' Aufruf und Prozehandle besorgen:
' hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(sShell,
eWindowStyle))
' If (hProcess = 0) Then
' ' Konnte kein Prozehandle bekommen - ging es evtl. zu schnell?
' Err.Description = "Der Start der Applikation """ & sApp & """ konnte
nicht besttigt werden. Bitte prfen Sie diese selbst."
' Err.Number = vbObjectError + 2002
' Else
' ' Erstmal Erfolg annehmen
' bSuccess = True
' ' Zeit nehmen
' lTimeStart = timeGetTime()
' Do
' ' Status ermitteln
' GetExitCodeProcess hProcess, rc
' ' Prozessorzeit abgeben
' DoEvents: Sleep 100
' If (timeGetTime() - lTimeStart > lTimeOutMilliSecs) Then
' ' Zeit ist abgelaufen
' Err.Description = "Zeitberschreitung beim Warten auf die
Applikation """ & sApp & """."
' Err.Number = vbObjectError + 2003
' rc = 0
' bSuccess = False
' End If
' Loop While rc = STILL_ACTIVE
' End If
' lExitCode = rc
'
'ErrTrap:
' ShellAndWaitForTermination = bSuccess
' Exit Function
'End Function
Public Sub ApiRaise(ByVal e As Long)
Err.Raise vbObjectError + 29000 + e, _
App.EXEName & ".Windows", ApiError(e)
End Sub
Public Function ApiError(ByVal e As Long) As String
Dim s As String, c As Long
s = String(256, 0)
c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
pNull, e, 0&, s, Len(s), ByVal pNull)
If c Then ApiError = Left$(s, c)
End Function
'Function Files(hFiles As Long, fi As CFileInfo, _
' ByVal sSpec As String, _
' Optional afAttr As Long = 0) As String
' Dim fd As WIN32_FIND_DATA, sName As String, f As Boolean, sPath As String
'
' ' Stop finding and close handle early
' If afAttr = -1 Then
' f = FindClose(hFiles)
' hFiles = 0: Exit Function
' End If
' f = True
' Do
' ' Get first or next file
' If hFiles = 0 Then
' hFiles = FindFirstFile(sSpec, fd)
' Else
' f = FindNextFile(hFiles, fd)
' End If
' If (f = False Or hFiles = INVALID_HANDLE_VALUE) Then
' If Err.LastDllError = ERROR_NO_MORE_FILES Then
' f = FindClose(hFiles)
' End If
' hFiles = 0: Exit Function
' End If
' ' Keep looping until something matches attributes
' Loop While (afAttr <> vbNormal) And _
' ((afAttr And fd.dwFileAttributes) = 0)
' ' Get file data and return through reference
' sPath = MUtility.GetFileDir(sSpec)
' sName = MUtility.StrZToStr(MBytes.BytesToStr(fd.cFileName))
' fi.CreateFromFile sPath & sName, fd.dwFileAttributes, _
' fd.nFileSizeLow, fd.ftLastWriteTime, _
' fd.ftLastAccessTime, fd.ftCreationTime
' Files = sName
'End Function
'
'' Efficient find files function
'Function FindFiles(sTarget As String, _
' Optional ByVal start As String) As Collection
'
' ' Statics for less memory use in recursive procedure
' Static sName As String, sSpec As String, nFound As New Collection
' Static fd As WIN32_FIND_DATA, iLevel As Long
' Dim hFiles As Long, f As Boolean
' If start = sEmpty Then start = CurDir$
' ' Maintain level to ensure collection is cleared first time
' If iLevel = 0 Then
' Set nFound = Nothing
' start = MUtility.NormalizePath(start)
' End If
' iLevel = iLevel + 1
'
' ' Find first file (get handle to find)
' hFiles = FindFirstFile(start & "*.*", fd)
' f = (hFiles <> INVALID_HANDLE_VALUE)
' Do While f
' sName = MBytes.ByteZToStr(fd.cFileName)
' ' Skip . and ..
' If Left$(sName, 1) <> "." Then
' sSpec = start & sName
' If fd.dwFileAttributes And vbDirectory Then
' DoEvents
' ' Call recursively on each directory
' FindFiles sTarget, sSpec & "\"
' ElseIf StrComp(sName, sTarget, 1) = 0 Then ' Text comparison
' ' Store found files in collection
' nFound.Add sSpec
' End If
' End If
' ' Keep looping until no more files
' f = FindNextFile(hFiles, fd)
' Loop
' f = FindClose(hFiles)
' ' Return the matching files in collection
' Set FindFiles = nFound
' iLevel = iLevel - 1
'End Function
'
'Function WalkAllFiles(fileit As IUseFile, _
' Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
' Optional ByVal start As String) As Boolean
'
' ' Statics for less memory use in recursive procedure
' Static sName As String, fd As WIN32_FIND_DATA, iLevel As Long
' Static fi As New CFileInfo
' Dim hFiles As Long, f As Boolean
' If start = sEmpty Then start = CurDir$
' ' Maintain level to ensure collection is cleared first time
' If iLevel = 0 Then start = MUtility.NormalizePath(start)
' iLevel = iLevel + 1
'
' ' Find first file (get handle to find)
' hFiles = FindFirstFile(start & "*.*", fd)
' f = (hFiles <> INVALID_HANDLE_VALUE)
' Do While f
' sName = MBytes.ByteZToStr(fd.cFileName)
' ' Skip . and ..
' If Left$(sName, 1) <> "." Then
' ' Create a file info object from file data
' fi.CreateFromFile start & sName, fd.dwFileAttributes, _
' fd.nFileSizeLow, fd.ftLastWriteTime, _
' fd.ftLastAccessTime, fd.ftCreationTime
' If fd.dwFileAttributes And vbDirectory Then
' If ewmf And ewmfDirs Then
' ' Let client use directory data
' WalkAllFiles = fileit.UseFile(iLevel, start, fi)
' ' If client returns True, walk terminates
' If WalkAllFiles Then Exit Function
' End If
' ' Call recursively on each directory
' WalkAllFiles = WalkAllFiles(fileit, ewmf, _
' start & sName & "\")
' Else
' If ewmf And ewmfFiles Then
' ' Let client use file data
' WalkAllFiles = fileit.UseFile(iLevel, start, fi)
' ' If client returns True, walk terminates
' If WalkAllFiles Then Exit Function
' End If
' End If
' End If
' ' Keep looping until no more files
' f = FindNextFile(hFiles, fd)
' Loop
' f = FindClose(hFiles)
' ' Return the matching files in collection
' iLevel = iLevel - 1
'End Function
'
'Function WalkFiles(fileit As IUseFile, _
' Optional ByVal ewmf As EWalkModeFile = ewmfBoth, _
' Optional ByVal start As String, _
' Optional UserData As Variant) As Boolean
'
' Dim sName As String, sSpec As String, fd As WIN32_FIND_DATA
' Dim hFiles As Long, f As Boolean, fi As New CFileInfo
' If start = sEmpty Then start = CurDir$
' start = MUtility.NormalizePath(start)
'
' ' Find first file (get handle to find)
' hFiles = FindFirstFile(start & "*.*", fd)
' f = (hFiles <> INVALID_HANDLE_VALUE)
' Do While f
' sName = MBytes.ByteZToStr(fd.cFileName)
' ' Skip . and ..
' If Left$(sName, 1) <> "." Then
' ' Create a file info object from file data
' fi.CreateFromFile start & sName, fd.dwFileAttributes, _
' fd.nFileSizeLow, fd.ftLastWriteTime, _
' fd.ftLastAccessTime, fd.ftCreationTime
' If fd.dwFileAttributes And vbDirectory Then
' If ewmf And ewmfDirs Then
' ' Let client use directory data
' WalkFiles = fileit.UseFile(UserData, start, fi)
' End If
' Else
' If ewmf And ewmfFiles Then
' ' Let client use file data
' WalkFiles = fileit.UseFile(UserData, start, fi)
' End If
' End If
' ' If client returns True, walk terminates
' If WalkFiles Then Exit Function
' End If
' ' Keep looping until no more files
' f = FindNextFile(hFiles, fd)
' Loop
' f = FindClose(hFiles)
'End Function
'
'#If fComponent = 0 Then
'Private Sub ErrRaise(e As Long)
' Dim sText As String, sSource As String
' If e > 1000 Then
' sSource = app.EXEName & ".FileTool"
' Select Case e
' Case eeBaseFileTool
' BugAssert True
' ' Case ee...
' ' Add additional errors
' End Select
' Err.Raise COMError(e), sSource, sText
' Else
' ' Raise standard Visual Basic error
' sSource = app.EXEName & ".VBError"
' Err.Raise e, sSource
' End If
'End Sub
'#End If
'
'
|
|