vbAccelerator - Contents of code file: mWinHook.bas

Attribute VB_Name = "mWindowsHook"
Option Explicit

' ===========================================================================
' API Calls:
' ===========================================================================
Private Declare Function SetWindowsHookEx Lib "user32" Alias
 "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpFn As Long, ByVal hmod As
 Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long)
 As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long,
 ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)

Public Enum EHTHookTypeConstants
   [_WH_MIN] = -1
   WH_CALLWNDPROC = 4
   WH_CBT = 5
   WH_DEBUG = 9
   WH_FOREGROUNDIDLE = 11
   WH_GETMESSAGE = 3
   'WH_HARDWARE = 8 ' Not implemented in Win32
   WH_JOURNALRECORD = 0
   WH_JOURNALPLAYBACK = 1
   WH_KEYBOARD = 2
   WH_MOUSE = 7
   WH_MSGFILTER = (-1)
   WH_SHELL = 10
   WH_SYSMSGFILTER = 6
   WH_CALLWNDPROCRET = 12
   [_WH_MAX] = 14
End Enum
Public Enum EHTHookErrorConstants
   eehHookBase = vbObjectError + 1048
End Enum

Public Type POINTAPI
   X As Long
   Y As Long
End Type
Public Type Msg '{     /* msg */
   hWnd As Long     '\\ The window whose Winproc will receive the message
   Message As Long  '\\ The message number
   wParam As Long
   lParam As Long
   time As Long     '\\ The time the message was posted
   pt As POINTAPI   '\\ The cursor position in screen coordinates
                    '\\  of the message
End Type
Public Type MOUSEHOOKSTRUCT '{ // ms
    pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
Public Type CWPSTRUCT
   lParam As Long
   wParam As Long
   Message As Long
   hWnd As Long
End Type
Public Type CWPRETSTRUCT
    lResult As Long
    lParam As Long
    wParam As Long
    Message As Long
    hWnd As Long
End Type
Public Const HC_ACTION = 0
Public Const HC_GETNEXT = 1
Public Const HC_NOREMOVE = 3
Public Const HC_SKIP = 2
Public Const HC_SYSMODALOFF = 5
Public Const HC_SYSMODALON = 4

Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As
 POINTAPI) As Long

' To Report API errors:
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
 (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal
 dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments
 As Long) As Long

' ===========================================================================
' Implementation
' ===========================================================================
' Hook handles:
Private m_hHook([_WH_MIN] To [_WH_MAX]) As Long
' Hook consumers:
Private Type tHookConsumer
   lPtr As Long                     ' Pointer to consumer object
   eType As EHTHookTypeConstants    ' Type of hook
End Type
Private m_tHookConsumer() As tHookConsumer
Private m_iConsumerCount As Long
Private m_eValidItem As EHTHookTypeConstants
#Const debugmsg = 0

Public Sub debugmsg(ByVal sMsg As String)
   #If debugmsg = 1 Then
      MsgBox sMsg, vbInformation
   #Else
      Debug.Print sMsg
   #End If
End Sub

Public Property Get ValidlParamType() As EHTHookTypeConstants
   ValidlParamType = m_eValidItem
End Property

Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim oTemp As Object
   ' Turn the pointer into an illegal, uncounted interface
   CopyMemory oTemp, lPtr, 4
   ' Do NOT hit the End button here! You will crash!
   ' Assign to legal reference
   Set ObjectFromPtr = oTemp
   ' Still do NOT hit the End button here! You will still crash!
   ' Destroy the illegal reference
   CopyMemory oTemp, 0&, 4
   ' OK, hit the End button if you must
End Property


Public Function WinAPIError(ByVal lLastDLLError As Long) As String
Dim sBuff As String
Dim lCount As Long
   
   ' Return the error message associated with LastDLLError:
   sBuff = String$(256, 0)
   lCount = FormatMessage( _
      FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
      0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
   If lCount <> 0 Then
      WinAPIError = Left$(sBuff, lCount)
   End If

End Function

Public Function InstallHook( _
      ByRef IHook As IWindowsHook, _
      ByVal eType As EHTHookTypeConstants _
   ) As Boolean
Dim hHook As Long
Dim lpFn As Long
Dim lErr As Long
Dim lPtr As Long
Dim i As Long
Dim bExists As Boolean
Dim iAvailSlot As Long
      
   ' If Hook not already installed:
   If (m_hHook(eType) = 0) Then
      Select Case eType
      Case WH_CALLWNDPROC
         lpFn = HookAddress(AddressOf CallWndProc)
      Case WH_CALLWNDPROCRET
         lpFn = HookAddress(AddressOf CallWndProcRet)
      Case WH_MSGFILTER
         lpFn = HookAddress(AddressOf MessageProc)
      Case WH_MOUSE
         lpFn = HookAddress(AddressOf MouseProc)
      Case WH_KEYBOARD
         lpFn = HookAddress(AddressOf KeyboardProc)
      Case WH_GETMESSAGE
         lpFn = HookAddress(AddressOf GetMsgProc)
      Case WH_FOREGROUNDIDLE
         lpFn = HookAddress(AddressOf ForegroundIdleProc)
      Case WH_SHELL
         lpFn = HookAddress(AddressOf ShellProc)
      Case Else
         Err.Raise eehHookBase + 1, App.EXEName & ".cVBALHook", "Unsupported
          Hook Type."
      End Select
      ' Add the hook:
      If lpFn <> 0 Then
         hHook = SetWindowsHookEx(eType, lpFn, 0&, GetCurrentThreadId())
         ' If we succeeded then set up the hook type:
         If (hHook <> 0) Then
            ' Succeeded; store the handle so we can restore it
            ' again later:
            m_hHook(eType) = hHook
         Else
            ' Failed:
            lErr = Err.LastDllError
            Err.Raise vbObjectError + 1049, App.EXEName & ".mHook",
             WinAPIError(lErr)
         End If
      End If
   End If

   ' If have a hook function:
   If (m_hHook(eType) <> 0) Then
      ' Add the class to the hook receive list:
      lPtr = ObjPtr(IHook)
      For i = 1 To m_iConsumerCount
         With m_tHookConsumer(i)
            If .eType = eType And .lPtr = lPtr Then
               bExists = True
            ElseIf .lPtr = 0 And iAvailSlot = 0 Then
               iAvailSlot = i
            End If
         End With
      Next i
      If Not (bExists) Then
         If (iAvailSlot = 0) Then
            m_iConsumerCount = m_iConsumerCount + 1
            ReDim Preserve m_tHookConsumer(1 To m_iConsumerCount) As
             tHookConsumer
            iAvailSlot = m_iConsumerCount
         End If
         With m_tHookConsumer(iAvailSlot)
            .lPtr = lPtr
            .eType = eType
         End With
      End If
      ' Success:
      debugmsg "mWindowsHook: Number of attached: " & m_iConsumerCount
      InstallHook = True
   End If

End Function

Private Function HookAddress(ByVal lPtr As Long) As Long
   ' Work around for VB's poor AddressOf implementation:
   HookAddress = lPtr
End Function
Private Function ShellProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook isn't really much use when it only applies to
   ' the current thread, to be honest.
   If nCode >= 0 Then
      ' Notification only:
      HookCall WH_SHELL, nCode, wParam, lParam
   End If
   ShellProc = CallNextHookEx(m_hHook(WH_FOREGROUNDIDLE), nCode, wParam, lParam)
End Function
Private Function ForegroundIdleProc(ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long) As Long
   ' This hook isn't particularly useful either; it continuously jabbers
   ' away saying that the foreground is idle almost all the time...
   If nCode >= 0 Then
      ' Notification only:
      HookCall WH_FOREGROUNDIDLE, nCode, wParam, lParam
   End If
   ForegroundIdleProc = CallNextHookEx(m_hHook(WH_FOREGROUNDIDLE), nCode,
    wParam, lParam)
End Function
Private Function MessageProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook allows you to intercept every message sent to every window
   ' in your application
   If nCode >= 0 Then
      If HookCall(WH_MSGFILTER, nCode, wParam, lParam) = 1 Then
         MessageProc = 0
         Exit Function
      End If
   End If
   MessageProc = CallNextHookEx(m_hHook(WH_MSGFILTER), nCode, wParam, lParam)
End Function
Private Function CallWndProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook is called just before the WindowProc is called for
   ' every window in your application.  The overhead of using this
   ' hook is very high, so only use it for short periods if possible.
   If nCode >= 0 Then
      ' Can discard the message.
      If HookCall(WH_CALLWNDPROC, nCode, wParam, lParam) = 1 Then
         ' not recommended though...
         CallWndProc = 0
         Exit Function
      End If
   End If
   CallWndProc = CallNextHookEx(m_hHook(WH_CALLWNDPROC), nCode, wParam, lParam)
End Function
Private Function CallWndProcRet(ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long) As Long
   ' Same as CallWndProc, but it is called just before the
   ' WindowProc for every window in your application is about
   ' to be returned.  Again, overhead is very high for this hook.
   If nCode >= 0 Then
      ' notification:
      HookCall WH_CALLWNDPROCRET, nCode, wParam, lParam
   End If
   CallWndProcRet = CallNextHookEx(m_hHook(WH_CALLWNDPROC), nCode, wParam,
    lParam)
End Function

Private Function GetMsgProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook is fired whenever any window in your application
   ' is about to call PeekMessage or GetMessage.
   If (nCode >= 0) Then
      ' Can't discard the message, but you can modify
      ' the values:
      HookCall WH_GETMESSAGE, nCode, wParam, lParam
   End If
   GetMsgProc = CallNextHookEx(m_hHook(WH_GETMESSAGE), nCode, wParam, lParam)
End Function
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook is called just before any mouse message is
   ' going to be posted to a window in your application:
   If (nCode >= 0) Then
      ' Can discard mouse events
      If (HookCall(WH_MOUSE, nCode, wParam, lParam) = 1) Then
         ' Not recommended; but you do it
         MouseProc = 1
         Exit Function
      End If
   End If
   MouseProc = CallNextHookEx(m_hHook(WH_MOUSE), nCode, wParam, lParam)
End Function

Private Function KeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
   ' This hook is called just before any WM_KEYDOWN or WM_KEYUP is
   ' going to be posted to a window in your application:
   If (nCode >= 0) Then
      ' Can discard keyboard events:
      If (HookCall(WH_KEYBOARD, nCode, wParam, lParam) = 1) Then
         ' Not recommended; but you do it
         KeyboardProc = 1
         Exit Function
      End If
   End If
   KeyboardProc = CallNextHookEx(m_hHook(WH_KEYBOARD), nCode, wParam, lParam)
End Function
Private Function HookCall(ByVal eType As EHTHookTypeConstants, ByVal nCode As
 Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim oItem As IWindowsHook
Dim i As Long
Dim bConsume As Boolean
   ' Call the HookProc for any consumers attached to the DLL:
   For i = 1 To m_iConsumerCount
      If (m_tHookConsumer(i).lPtr <> 0) And (m_tHookConsumer(i).eType = eType)
       Then
         Set oItem = ObjectFromPtr(m_tHookConsumer(i).lPtr)
         m_eValidItem = eType
         oItem.HookProc nCode, wParam, lParam, bConsume
         m_eValidItem = 0
         If (bConsume) Then
            ' Note: consuming is not recommended unless you really
            ' have to
            HookCall = 1
            Exit Function
         End If
      End If
   Next i
   HookCall = 0
End Function

Public Function RemoveHook( _
      ByVal IHook As IWindowsHook, _
      ByVal eType As EHTHookTypeConstants _
   )
Dim i As Long
Dim lPtr As Long
Dim iRefCount As Long

   ' Remove the hook from the hook list:
   lPtr = ObjPtr(IHook)
   For i = 1 To m_iConsumerCount
      With m_tHookConsumer(i)
         If (.eType = eType) Then
            If (.lPtr = lPtr) Then
               .lPtr = 0
               .eType = -2
            ElseIf (.lPtr <> 0) Then
               iRefCount = iRefCount + 1
            End If
         End If
      End With
   Next i
   
   ' If no more clients on this hook then remove the hook:
   If (iRefCount = 0) Then
      If (m_hHook(eType) <> 0) Then
         UnhookWindowsHookEx m_hHook(eType)
         m_hHook(eType) = 0
      End If
   End If
   
End Function