VBCommons/api/ex_WinAPI.bas

Attribute VB_Name = "ex_WinAPI"
' ================ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> =============
' 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 <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 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