542 lines
17 KiB
QBasic
542 lines
17 KiB
QBasic
Attribute VB_Name = "ex_WinAPI"
|
|
' ================ Ìîäóëü äëÿ ðàáîòû ñ ôóíêöèÿìè óðîâíÿ ïðèëîæåíèÿ =============
|
|
' Shared module version: 20220812
|
|
' Tested in: TestCommons
|
|
' Depends on:
|
|
' Required reference: Scripting, Shell32
|
|
Option Private Module
|
|
Option Explicit
|
|
|
|
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal nMilliseconds As LongPtr)
|
|
Public Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
|
|
Public Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
|
|
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
|
|
Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
|
|
(ByVal nHwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
|
|
|
|
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal nHwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
|
|
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal nHwnd As Long, ByVal nDEvent As Long) As Long
|
|
|
|
Private Const DATAOBJECT_BINDING$ = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}" ' ID Äëÿ îáúåêòà DataObject
|
|
|
|
Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal nHwnd As Long) As Long
|
|
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal nHwnd As Long) As Long
|
|
|
|
Private Declare PtrSafe Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As LongPtr
|
|
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
|
|
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (iDestination As Any, iSource As Any, ByVal nLength As LongPtr)
|
|
|
|
Public Enum TApplication
|
|
T_APP_UNDEF = 0
|
|
[_First] = 1
|
|
|
|
T_APP_EXCEL = 1
|
|
T_APP_WORD = 2
|
|
T_APP_VISIO = 3
|
|
|
|
[_Last] = 3
|
|
End Enum
|
|
|
|
Public Function OfficeCommandLine() As String
|
|
OfficeCommandLine = String$(lstrlenW(GetCommandLine()), 0)
|
|
Call CopyMemory(ByVal StrPtr(OfficeCommandLine), ByVal GetCommandLine(), LenB(OfficeCommandLine))
|
|
End Function
|
|
|
|
Public Function ActivateWindow(sClass$, Optional sWindow$ = vbNullString) As Boolean
|
|
On Error Resume Next
|
|
ActivateWindow = False
|
|
Dim nWindow&: nWindow = FindWindow(sClass, sWindow)
|
|
If nWindow <= 0 Then _
|
|
Exit Function
|
|
ActivateWindow = ActivateWindowHwnd(nWindow)
|
|
End Function
|
|
|
|
Public Function ActivateWindowHwnd(nWindow&) As Boolean
|
|
On Error Resume Next
|
|
ActivateWindowHwnd = False
|
|
If nWindow <= 0 Then _
|
|
Exit Function
|
|
If BringWindowToTop(nWindow) = 0 Then _
|
|
Exit Function
|
|
|
|
Call SetFocus(nWindow)
|
|
ActivateWindowHwnd = True
|
|
End Function
|
|
|
|
Public Function ApplicationFromExtension(sExtension$) As TApplication
|
|
ApplicationFromExtension = T_APP_UNDEF
|
|
Select Case VBA.UCase(sExtension)
|
|
Case "XLS": ApplicationFromExtension = T_APP_EXCEL
|
|
Case "XLSX": ApplicationFromExtension = T_APP_EXCEL
|
|
Case "XLSM": ApplicationFromExtension = T_APP_EXCEL
|
|
Case "XLTM": ApplicationFromExtension = T_APP_EXCEL
|
|
Case "RTF": ApplicationFromExtension = T_APP_WORD
|
|
Case "DOC": ApplicationFromExtension = T_APP_WORD
|
|
Case "DOCX": ApplicationFromExtension = T_APP_WORD
|
|
Case "DOCM": ApplicationFromExtension = T_APP_WORD
|
|
Case "DOTM": ApplicationFromExtension = T_APP_WORD
|
|
Case "VSDX": ApplicationFromExtension = T_APP_VISIO
|
|
Case "VSDM": ApplicationFromExtension = T_APP_VISIO
|
|
Case "VSTX": ApplicationFromExtension = T_APP_VISIO
|
|
Case "VSTM": ApplicationFromExtension = T_APP_VISIO
|
|
End Select
|
|
End Function
|
|
|
|
Public Function ApplicationTypeFor(iApp As Object) As TApplication
|
|
ApplicationTypeFor = T_APP_UNDEF
|
|
Select Case iApp.Name
|
|
Case "Microsoft Excel": ApplicationTypeFor = T_APP_EXCEL
|
|
Case "Microsoft Word": ApplicationTypeFor = T_APP_WORD
|
|
Case "Microsoft Visio": ApplicationTypeFor = T_APP_VISIO
|
|
End Select
|
|
End Function
|
|
|
|
Public Function ApplicationWrapper(iType As TApplication) As Object
|
|
Dim iApplication As Object: Set iApplication = Application
|
|
If Application.Name = "Microsoft Visio" Then _
|
|
Call Err.Raise(vbObjectError, Description:="Visio does not support meta wrappers")
|
|
Select Case iType
|
|
Case T_APP_EXCEL: Set ApplicationWrapper = iApplication.Run("CreateWrapperXL")
|
|
Case T_APP_WORD: Set ApplicationWrapper = iApplication.Run("CreateWrapperWord")
|
|
Case T_APP_VISIO: Set ApplicationWrapper = iApplication.Run("CreateWrapperVisio")
|
|
End Select
|
|
End Function
|
|
|
|
' To use application wrapper copy required CreateWrapper functions to Main module and uncomment them
|
|
'Public Function CreateWrapperXL() As API_XLWrapper
|
|
' Set CreateWrapperXL = New API_XLWrapper
|
|
'End Function
|
|
'
|
|
'Public Function CreateWrapperWord() As API_WordWrapper
|
|
' Set CreateWrapperWord = New API_WordWrapper
|
|
'End Function
|
|
'
|
|
'Public Function CreateWrapperVisio() As API_VisioWrapper
|
|
' Set CreateWrapperVisio = New API_VisioWrapper
|
|
'End Function
|
|
|
|
' Wrapper for active document
|
|
Public Function OfficeActiveWrapper() As Object
|
|
Dim activeApp As Object: Set activeApp = Application
|
|
Dim iWrapper As Object
|
|
|
|
Select Case ApplicationTypeFor(Application)
|
|
Case T_APP_EXCEL
|
|
Set iWrapper = ApplicationWrapper(T_APP_EXCEL)
|
|
Call iWrapper.SetDocument(activeApp.ActiveWorkbook)
|
|
|
|
Case T_APP_WORD
|
|
Set iWrapper = ApplicationWrapper(T_APP_WORD)
|
|
Call iWrapper.SetDocument(activeApp.ActiveDocument)
|
|
|
|
Case T_APP_VISIO
|
|
Set iWrapper = ApplicationWrapper(T_APP_VISIO)
|
|
Call iWrapper.SetDocument(activeApp.ActiveDocument)
|
|
End Select
|
|
|
|
Set OfficeActiveWrapper = iWrapper
|
|
End Function
|
|
|
|
' Wrapper for this document
|
|
Public Function OfficeThisWrapper() As Object
|
|
Dim activeApp As Object: Set activeApp = Application
|
|
Dim iWrapper As Object
|
|
|
|
Select Case ApplicationTypeFor(Application)
|
|
Case T_APP_EXCEL
|
|
Set iWrapper = ApplicationWrapper(T_APP_EXCEL)
|
|
Call iWrapper.SetDocument(activeApp.ThisWorkbook)
|
|
|
|
Case T_APP_WORD
|
|
Set iWrapper = ApplicationWrapper(T_APP_WORD)
|
|
Call iWrapper.SetDocument(activeApp.ThisDocument)
|
|
|
|
Case T_APP_VISIO
|
|
Set iWrapper = ApplicationWrapper(T_APP_VISIO)
|
|
Call iWrapper.SetDocument(activeApp.ThisDocument)
|
|
End Select
|
|
|
|
Set OfficeThisWrapper = iWrapper
|
|
End Function
|
|
|
|
' Path to active document folder
|
|
Public Function OfficeActivePath() As String
|
|
Dim activeApp As Object: Set activeApp = Application
|
|
Select Case ApplicationTypeFor(Application)
|
|
Case T_APP_EXCEL: OfficeActivePath = activeApp.ActiveWorkbook.Path
|
|
Case T_APP_WORD: OfficeActivePath = activeApp.ActiveDocument.Path
|
|
Case T_APP_VISIO: OfficeActivePath = activeApp.ActiveDocument.Path
|
|
End Select
|
|
End Function
|
|
|
|
' Path to this document folder
|
|
Public Function OfficeThisPath() As String
|
|
Dim activeApp As Object: Set activeApp = Application
|
|
Select Case ApplicationTypeFor(Application)
|
|
Case T_APP_EXCEL: OfficeThisPath = activeApp.ThisWorkbook.Path
|
|
Case T_APP_WORD: OfficeThisPath = activeApp.ThisDocument.Path
|
|
Case T_APP_VISIO: OfficeThisPath = activeApp.ThisDocument.Path
|
|
End Select
|
|
End Function
|
|
|
|
Public Function AddToClipboard(sText$)
|
|
With CreateObject(DATAOBJECT_BINDING)
|
|
Call .SetText(sText)
|
|
.PutInClipboard
|
|
End With
|
|
End Function
|
|
|
|
Public Function RetrieveFromClipboard() As String
|
|
With CreateObject(DATAOBJECT_BINDING)
|
|
Call .GetFromClipboard
|
|
RetrieveFromClipboard = .GetText
|
|
End With
|
|
End Function
|
|
|
|
Public Function WindowsTempFolder() As String
|
|
WindowsTempFolder = Environ("TEMP")
|
|
End Function
|
|
|
|
Public Function EnsureFolderExists(sPath$, Optional ByRef fso As Scripting.FileSystemObject = Nothing)
|
|
If fso Is Nothing Then _
|
|
Set fso = New Scripting.FileSystemObject
|
|
If fso.FolderExists(sPath) Then _
|
|
Exit Function
|
|
|
|
Dim sParent$: sParent = sPath
|
|
Do
|
|
If sParent = vbNullString Then _
|
|
Exit Function
|
|
If VBA.Right(sParent, 1) <> "\" Then _
|
|
Exit Do
|
|
sParent = VBA.Left(sParent, VBA.Len(sParent) - 1)
|
|
Loop
|
|
|
|
Dim nDelim&: nDelim = VBA.InStrRev(sParent, "\")
|
|
If nDelim = 0 Then _
|
|
Exit Function
|
|
sParent = VBA.Left(sParent, nDelim - 1)
|
|
|
|
Call EnsureFolderExists(sParent, fso)
|
|
Call fso.CreateFolder(sPath)
|
|
End Function
|
|
|
|
Public Function CreateTextFileUTF16(sFile$, Optional bOverwrite = False) As Boolean
|
|
CreateTextFileUTF16 = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not bOverwrite Then _
|
|
If fso.FileExists(sFile) Then _
|
|
Exit Function
|
|
|
|
On Error GoTo EXIT_FALSE
|
|
Call fso.CreateTextFile(sFile, Overwrite:=bOverwrite, Unicode:=True).Close
|
|
On Error GoTo 0
|
|
|
|
CreateTextFileUTF16 = True
|
|
Exit Function
|
|
EXIT_FALSE:
|
|
End Function
|
|
|
|
Public Function AppendTextToFileUTF16(sFile$, sMsg$) As Boolean
|
|
Const UTF16_MODE = TristateTrue
|
|
AppendTextToFileUTF16 = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FileExists(sFile) Then _
|
|
Exit Function
|
|
|
|
On Error GoTo RETURN_FALSE
|
|
Dim fs As Scripting.TextStream
|
|
Set fs = fso.OpenTextFile(sFile, ForAppending, Format:=UTF16_MODE)
|
|
If fs Is Nothing Then _
|
|
Exit Function
|
|
|
|
Call fs.WriteLine(sMsg)
|
|
Call fs.Close
|
|
|
|
AppendTextToFileUTF16 = True
|
|
Exit Function
|
|
RETURN_FALSE:
|
|
End Function
|
|
|
|
Public Function ReadTextFromFileUTF16(sFile$, ByRef sResult$) As Boolean
|
|
Const UTF16_MODE = TristateTrue
|
|
ReadTextFromFileUTF16 = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FileExists(sFile) Then _
|
|
Exit Function
|
|
|
|
On Error GoTo RETURN_FALSE
|
|
Dim fs As Scripting.TextStream
|
|
Set fs = fso.OpenTextFile(sFile, ForReading, Format:=UTF16_MODE)
|
|
If fs Is Nothing Then _
|
|
Exit Function
|
|
|
|
sResult = fs.ReadAll
|
|
Call fs.Close
|
|
|
|
ReadTextFromFileUTF16 = True
|
|
Exit Function
|
|
RETURN_FALSE:
|
|
End Function
|
|
|
|
Public Function CopyFileOrFolder(sSource$, sDestination$, Optional ByRef fso As Scripting.FileSystemObject = Nothing) As Boolean
|
|
CopyFileOrFolder = False
|
|
|
|
If fso Is Nothing Then _
|
|
Set fso = New Scripting.FileSystemObject
|
|
|
|
Dim bIsFile As Boolean: bIsFile = fso.FileExists(sSource)
|
|
Dim bIsFolder As Boolean: bIsFolder = fso.FolderExists(sSource)
|
|
If Not bIsFile And Not bIsFolder Then _
|
|
Exit Function
|
|
|
|
Call EnsureFolderExists(fso.GetParentFolderName(sDestination), fso)
|
|
On Error GoTo RETURN_FALSE
|
|
If bIsFile Then
|
|
Call fso.CopyFile(sSource, sDestination, OverWriteFiles:=True)
|
|
Else
|
|
Call fso.CopyFolder(sSource, sDestination, OverWriteFiles:=True)
|
|
End If
|
|
On Error GoTo 0
|
|
|
|
CopyFileOrFolder = True
|
|
RETURN_FALSE:
|
|
End Function
|
|
|
|
Public Function MoveFileOrFolder(sSource$, sDestination$, Optional fso As Scripting.FileSystemObject = Nothing) As Boolean
|
|
MoveFileOrFolder = False
|
|
If sSource = sDestination Then _
|
|
Exit Function
|
|
If Not CopyFileOrFolder(sSource, sDestination, fso) Then _
|
|
Exit Function
|
|
|
|
On Error GoTo RETURN_FALSE
|
|
If fso.FileExists(sSource) Then _
|
|
Call fso.DeleteFile(sSource)
|
|
If fso.FolderExists(sSource) Then _
|
|
Call fso.DeleteFolder(sSource)
|
|
On Error GoTo 0
|
|
|
|
MoveFileOrFolder = True
|
|
Exit Function
|
|
|
|
RETURN_FALSE:
|
|
MoveFileOrFolder = False
|
|
End Function
|
|
|
|
Public Function ListFilesIn(sTargetFolder$, Optional sMask$ = "*.*") As Collection
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FolderExists(sTargetFolder) Then _
|
|
Exit Function
|
|
|
|
Dim iFiles As New Collection
|
|
Dim cQueue As New Collection
|
|
Call cQueue.Add(fso.GetFolder(sTargetFolder))
|
|
|
|
Dim aFolder As Scripting.Folder
|
|
Dim subFolder As Scripting.Folder
|
|
Dim aFile As Scripting.File
|
|
Do While cQueue.Count > 0
|
|
Set aFolder = cQueue(1)
|
|
Call cQueue.Remove(1)
|
|
|
|
For Each subFolder In aFolder.SubFolders
|
|
Call cQueue.Add(subFolder)
|
|
Next subFolder
|
|
|
|
For Each aFile In aFolder.files
|
|
If VBA.UCase(aFile.Name) Like VBA.UCase(sMask) Then _
|
|
Call iFiles.Add(aFile.Path)
|
|
Next aFile
|
|
Loop
|
|
|
|
Set ListFilesIn = iFiles
|
|
End Function
|
|
|
|
Public Function ForEachFileRecursive(sTargetFolder$, oCallback As Object, sFuncName$)
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FolderExists(sTargetFolder) Then _
|
|
Exit Function
|
|
|
|
Dim cQueue As New Collection
|
|
Call cQueue.Add(fso.GetFolder(sTargetFolder))
|
|
|
|
Dim aFolder As Scripting.Folder
|
|
Dim subFolder As Scripting.Folder
|
|
Dim aFile As Scripting.File
|
|
Do While cQueue.Count > 0
|
|
Set aFolder = cQueue(1)
|
|
Call cQueue.Remove(1)
|
|
|
|
For Each subFolder In aFolder.SubFolders
|
|
Call cQueue.Add(subFolder)
|
|
Next subFolder
|
|
|
|
For Each aFile In aFolder.files
|
|
Call CallByName(oCallback, sFuncName, VbMethod, aFile)
|
|
Next aFile
|
|
Loop
|
|
End Function
|
|
|
|
' Callback should return TRUE to continue recursive
|
|
Public Function ForEachFolderRecursive(sTargetFolder$, oCallback As Object, sFuncName$)
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FolderExists(sTargetFolder) Then _
|
|
Exit Function
|
|
|
|
Dim cQueue As New Collection
|
|
Call cQueue.Add(fso.GetFolder(sTargetFolder))
|
|
|
|
Dim aFolder As Scripting.Folder
|
|
Dim subFolder As Scripting.Folder
|
|
Dim aFile As Scripting.File
|
|
Do While cQueue.Count > 0
|
|
Set aFolder = cQueue(1)
|
|
Call cQueue.Remove(1)
|
|
|
|
If CallByName(oCallback, sFuncName, VbMethod, aFolder) Then
|
|
For Each subFolder In aFolder.SubFolders
|
|
Call cQueue.Add(subFolder)
|
|
Next subFolder
|
|
End If
|
|
Loop
|
|
End Function
|
|
|
|
Public Function FileToMD5(sTargetFile$) As String
|
|
FileToMD5 = ComputeFileHash(sTargetFile, "MD5CryptoServiceProvider")
|
|
End Function
|
|
|
|
Public Function FileToSHA1(sTargetFile$) As String
|
|
FileToSHA1 = ComputeFileHash(sTargetFile, "SHA1CryptoServiceProvider")
|
|
End Function
|
|
|
|
Public Function UnzipFile(sTargetFile$, sDestinationFolder$) As Boolean
|
|
Const OPT_DISABLE_DIALOGS = 4
|
|
Const OPT_YES_TO_ALL = 16
|
|
|
|
UnzipFile = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FileExists(sTargetFile) Then _
|
|
Exit Function
|
|
|
|
Dim sExt$: sExt = fso.GetExtensionName(sTargetFile)
|
|
Dim sZip$: sZip = sTargetFile
|
|
If sExt <> "zip" Then
|
|
sZip = Left(sTargetFile, Len(sTargetFile) - Len(sExt) - 1) & ".tmp.zip"
|
|
Call fso.GetFile(sTargetFile).Copy(sZip)
|
|
End If
|
|
|
|
Call EnsureFolderExists(sDestinationFolder, fso)
|
|
|
|
Dim aShell As New Shell32.Shell
|
|
Call aShell.Namespace(sDestinationFolder).CopyHere(aShell.Namespace(sZip).Items, OPT_DISABLE_DIALOGS + OPT_YES_TO_ALL)
|
|
|
|
If sExt <> "zip" Then _
|
|
Call fso.DeleteFile(sZip)
|
|
|
|
UnzipFile = True
|
|
End Function
|
|
|
|
Public Function ZipFolder(sTargetFolder$, sDestinationFile$) As Boolean
|
|
ZipFolder = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FolderExists(sTargetFolder) Then _
|
|
Exit Function
|
|
|
|
Dim sZip$: sZip = sDestinationFile
|
|
Dim sExt$: sExt = fso.GetExtensionName(sDestinationFile)
|
|
If sExt <> "zip" Then _
|
|
sZip = Left(sDestinationFile, Len(sDestinationFile) - Len(sExt) - 1) & ".zip"
|
|
|
|
Call CreateEmptyZip(sZip)
|
|
Dim aShell As New Shell32.Shell
|
|
Call aShell.Namespace(sZip).CopyHere(aShell.Namespace(sTargetFolder).Items)
|
|
|
|
' Wait for zipping to finish
|
|
On Error Resume Next
|
|
Dim nTimeout&: nTimeout = 90 ' seconds
|
|
Do Until aShell.Namespace(sZip).Items.Count = aShell.Namespace(sTargetFolder).Items.Count
|
|
Call Sleep(1000)
|
|
nTimeout = nTimeout - 1
|
|
If nTimeout = 0 Then _
|
|
Exit Function
|
|
Loop
|
|
On Error GoTo 0
|
|
|
|
If sExt <> "zip" Then
|
|
Call fso.CopyFile(sZip, sDestinationFile)
|
|
Call fso.DeleteFile(sZip)
|
|
End If
|
|
|
|
ZipFolder = True
|
|
End Function
|
|
|
|
Public Function PositionInMiddle(targetForm As Object)
|
|
Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (targetForm.Height / 2)
|
|
Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (targetForm.Width / 2)
|
|
|
|
targetForm.StartUpPosition = 0
|
|
targetForm.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
|
|
targetForm.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
|
|
End Function
|
|
|
|
' ========
|
|
Private Function CreateEmptyZip(sTarget$)
|
|
Dim nFileID%: nFileID = FreeFile
|
|
Open sTarget For Output As #nFileID
|
|
Print #nFileID, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
|
|
Close #nFileID
|
|
End Function
|
|
|
|
Private Function ComputeFileHash(sTargetFile$, sCryptoProvider$) As String
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FileExists(sTargetFile) Then
|
|
ComputeFileHash = "File not exists"
|
|
Exit Function
|
|
End If
|
|
|
|
Dim nFileID&: nFileID = VBA.FreeFile
|
|
On Error GoTo CANNOT_OPEN
|
|
Open sTargetFile For Binary Access Read As nFileID
|
|
On Error GoTo 0
|
|
|
|
Dim iEncrypter As Object: Set iEncrypter = CreateObject("System.Security.Cryptography." & sCryptoProvider)
|
|
Dim iBuffer() As Byte
|
|
Dim nBlockSize&: nBlockSize = 2 ^ 16
|
|
Dim nFileSize&: nFileSize = VBA.LOF(nFileID)
|
|
If nFileSize < nBlockSize Then _
|
|
nBlockSize = ((nFileSize + 1024) \ 1024) * 1024
|
|
|
|
ReDim iBuffer(0 To nBlockSize - 1)
|
|
Dim i&
|
|
For i = 1 To nFileSize \ nBlockSize Step 1
|
|
Get nFileID, , iBuffer
|
|
Call iEncrypter.TransformBlock(iBuffer, 0, nBlockSize, iBuffer, 0)
|
|
Next
|
|
|
|
Get nFileID, , iBuffer
|
|
Call iEncrypter.TransformFinalBlock(iBuffer, 0, nFileSize Mod nBlockSize)
|
|
iBuffer = iEncrypter.Hash
|
|
|
|
Close nFileID
|
|
Call iEncrypter.Clear
|
|
|
|
Dim nPos&
|
|
Dim sHash$
|
|
For nPos = 1 To VBA.LenB(iBuffer)
|
|
sHash = sHash & VBA.LCase(VBA.Right("0" & VBA.Hex(VBA.AscB(VBA.MidB(iBuffer, nPos, 1))), 2))
|
|
Next nPos
|
|
|
|
Set iEncrypter = Nothing
|
|
ComputeFileHash = sHash
|
|
Exit Function
|
|
|
|
CANNOT_OPEN:
|
|
ComputeFileHash = "Cannot open file"
|
|
End Function
|