vbAccelerator - Contents of code file: mHook.bas

Attribute VB_Name = "mHook"
Option Explicit

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
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
Private Const WH_KEYBOARD As Long = 2
Private Const MSGF_MENU = 2
Private Const HC_ACTION = 0
Private Const WH_MOUSE As Long = 7
Private Const WM_MOUSEMOVE = &H200
Private Const WM_NCMOUSEMOVE = &HA0

Private m_iKeyHookCount As Long
Private m_lKeyHookhWnd() As Long
Private m_hKeyHook As Long

Private m_iMouseHookCount As Long
Private m_lMouseHookhWnd() As Long
Private m_hMouseHook As Long

Public Sub AttachMouseHook(ByVal hWnd As Long)
   
   Dim lpfn As Long
   If (m_iMouseHookCount = 0) Then
      lpfn = HookAddress(AddressOf MouseFilter)
      m_hMouseHook = SetWindowsHookEx(WH_MOUSE, lpfn, 0&, GetCurrentThreadId())
      Debug.Assert (m_hMouseHook <> 0)
   End If
   
   Dim i As Long
   For i = 1 To m_iMouseHookCount
      If hWnd = m_lMouseHookhWnd(i) Then
         ' we already have it
         'Debug.Assert False
         Exit Sub
      End If
   Next i
   
   If Not (m_hMouseHook = 0) Then
      ReDim Preserve m_lMouseHookhWnd(1 To m_iMouseHookCount + 1) As Long
      m_iMouseHookCount = m_iMouseHookCount + 1
      m_lMouseHookhWnd(m_iMouseHookCount) = hWnd
   End If
   
End Sub

Public Sub DetachMouseHook(ByVal hWnd As Long)
Dim i As Long
Dim lPtr As Long
Dim iThis As Long
   
   For i = 1 To m_iMouseHookCount
      If m_lMouseHookhWnd(i) = hWnd Then
         iThis = i
         Exit For
      End If
   Next i
   
   If Not (iThis = 0) Then
      If m_iMouseHookCount > 1 Then
         For i = iThis To m_iMouseHookCount - 1
            m_lMouseHookhWnd(i) = m_lMouseHookhWnd(i + 1)
         Next i
      End If
      m_iMouseHookCount = m_iMouseHookCount - 1
      If m_iMouseHookCount >= 1 Then
         ReDim Preserve m_lMouseHookhWnd(1 To m_iMouseHookCount) As Long
      Else
         Erase m_lMouseHookhWnd
      End If
   Else
      ' hmmm
   End If
   
   If m_iMouseHookCount <= 0 Then
      If Not (m_hMouseHook = 0) Then
         UnhookWindowsHookEx m_hMouseHook
         m_hMouseHook = 0
      End If
   End If

End Sub


Public Sub AttachKeyboardHook(ByVal hWnd As Long)
   
   Dim lpfn As Long
   If m_iKeyHookCount = 0 Then
      lpfn = HookAddress(AddressOf KeyboardFilter)
      m_hKeyHook = SetWindowsHookEx(WH_KEYBOARD, lpfn, 0&, GetCurrentThreadId())
      Debug.Assert (m_hKeyHook <> 0)
   End If
   
   Dim i As Long
   For i = 1 To m_iKeyHookCount
      If hWnd = m_lKeyHookhWnd(i) Then
         ' we already have it:
         Debug.Assert False
         Exit Sub
      End If
   Next i
      
   If Not (m_hKeyHook = 0) Then
      ReDim Preserve m_lKeyHookhWnd(1 To m_iKeyHookCount + 1) As Long
      m_iKeyHookCount = m_iKeyHookCount + 1
      m_lKeyHookhWnd(m_iKeyHookCount) = hWnd
   End If
   
End Sub

Public Sub DetachKeyboardHook(ByVal hWnd As Long)
Dim i As Long
Dim lPtr As Long
Dim iThis As Long
   
   For i = 1 To m_iKeyHookCount
      If m_lKeyHookhWnd(i) = hWnd Then
         iThis = i
         Exit For
      End If
   Next i
   
   If Not (iThis = 0) Then
      If m_iKeyHookCount > 1 Then
         For i = iThis To m_iKeyHookCount - 1
            m_lKeyHookhWnd(i) = m_lKeyHookhWnd(i + 1)
         Next i
      End If
      m_iKeyHookCount = m_iKeyHookCount - 1
      If m_iKeyHookCount >= 1 Then
         ReDim Preserve m_lKeyHookhWnd(1 To m_iKeyHookCount) As Long
      Else
         Erase m_lKeyHookhWnd
      End If
   Else
      ' hmmm
   End If
   
   If m_iKeyHookCount <= 0 Then
      If Not (m_hKeyHook = 0) Then
         UnhookWindowsHookEx m_hKeyHook
         m_hKeyHook = 0
      End If
   End If

End Sub

Private Function HookAddress(ByVal lPtr As Long) As Long
   HookAddress = lPtr
End Function


Private Function KeyboardFilter(ByVal nCode As Long, ByVal wParam As Long,
 ByVal lParam As Long) As Long
Dim bKeyUp As Boolean
Dim bAlt As Boolean, bCtrl As Boolean, bShift As Boolean
Dim bFKey As Boolean, bEscape As Boolean, bDelete As Boolean
Dim wMask As ShiftConstants
Dim i As Long
Dim lErr As Long
Dim ctlPicker As vbalPicker
Dim bProcessed As Boolean
Dim bConsume As Boolean

On Error GoTo ErrorHandler

   If nCode = HC_ACTION And m_iKeyHookCount > 0 Then
      ' Key up or down:
      bKeyUp = ((lParam And &H80000000) = &H80000000)
      bShift = (GetAsyncKeyState(vbKeyShift) <> 0)
      bAlt = (GetAsyncKeyState(vbKeyMenu) <> 0) Or (wParam = vbKeyMenu)
      bCtrl = (GetAsyncKeyState(vbKeyControl) <> 0)
      bFKey = ((wParam >= vbKeyF1) And (wParam <= vbKeyF12))
      bEscape = (wParam = vbKeyEscape)
      bDelete = (wParam = vbKeyDelete)
      wMask = Abs(bShift * vbShiftMask) Or Abs(bCtrl * vbCtrlMask) Or Abs(bAlt
       * vbAltMask)
      For i = m_iKeyHookCount To 1 Step -1
         If Not (m_lKeyHookhWnd(i) = 0) Then
            lErr = 0
            On Error Resume Next
            gbValidOwner m_lKeyHookhWnd(i), ctlPicker
            lErr = Err.Number
            On Error GoTo 0
            If (lErr = 0) And Not (ctlPicker Is Nothing) Then
               If ctlPicker.fKeyPress(wParam, wMask, bKeyUp) Then
                  bConsume = True
                  Exit For
               ElseIf ctlPicker.fInMenuLoop Then
                  bConsume = True
               End If
            End If
         End If
      Next i
   End If
   
   
   bProcessed = True
   If (bConsume) Then
      KeyboardFilter = 1
   Else
      KeyboardFilter = CallNextHookEx(m_hKeyHook, nCode, wParam, lParam)
   End If
   Exit Function

ErrorHandler:
   Debug.Print "Keyboard Hook Error!"
   If Not bProcessed Then
      On Error Resume Next
      KeyboardFilter = CallNextHookEx(m_hKeyHook, nCode, wParam, lParam)
   End If
   Exit Function
   
End Function

Private Function MouseFilter(ByVal nCode As Long, ByVal wParam As Long, ByVal
 lParam As Long) As Long
Dim lErr As Long
Dim i As Long
Dim ctlPicker As vbalPicker
Dim bProcessed As Boolean
Dim bInNone As Boolean

On Error GoTo ErrorHandler
   
   If (nCode = HC_ACTION) Then
      If Not ((wParam = WM_MOUSEMOVE) Or (wParam = WM_NCMOUSEMOVE)) Then
         bInNone = True
         Dim tMHS As MOUSEHOOKSTRUCT
         CopyMemory tMHS, ByVal lParam, Len(tMHS)
         Debug.Print Hex(tMHS.dwExtraInfo)
         For i = m_iMouseHookCount To 1 Step -1
            If m_lMouseHookhWnd(i) <> 0 Then
               lErr = 0
               On Error Resume Next
               gbValidOwner m_lMouseHookhWnd(i), ctlPicker
               lErr = Err.Number
               On Error GoTo 0
               If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                  If ctlPicker.fMousePress(tMHS.pt.x, tMHS.pt.y) Then
                     bInNone = False
                     Exit For
                  End If
               End If
            End If
         Next i
         If bInNone Then
            i = 1
            Do While m_iMouseHookCount > 0
               lErr = 0
               On Error Resume Next
               gbValidOwner m_lMouseHookhWnd(i), ctlPicker
               lErr = Err.Number
               On Error GoTo 0
               If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                  ctlPicker.fEndMenuLoop
               End If
            Loop
         End If
      End If
   End If
   
   bProcessed = True
   MouseFilter = CallNextHookEx(m_hMouseHook, nCode, wParam, lParam)
   Exit Function
   
ErrorHandler:
   Debug.Print "Mouse Hook Error!"
   If Not bProcessed Then
      On Error Resume Next
      MouseFilter = CallNextHookEx(m_hMouseHook, nCode, wParam, lParam)
   End If
   Exit Function
   
End Function