Attribute VB_Name = "mWheelHook"
Option Explicit

Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
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 GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

Private Const WH_MOUSE = &H7&
Private Const WM_MOUSEWHEEL = &H20A&

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type Msg
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Type MouseHookStruct ' Information about a mouse event passed to a WH_MOUSE hook procedure
   pt As POINTAPI            ' POINT structure that contains the x/y coordinates of the cursor
   hWnd As Long              ' Handle to the window that will receive the mouse message
   wHitTestCode As Long      ' Specifies the hit-test value
   dwExtraInfo As Long       ' Specifies extra information associated with the message
End Type

Private Declare Function WindowFromPoint Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cBytes As Long)

Private lPrevProc As Long
Private Ctl_hWnds(50) As Long ' Arbitrary control limit
Private cchWnds As Long

' Can be called up to 50 times to add each control
Public Sub HookWheel(ByVal Ctrl_hWnd As Long)
   If InTheIDE Then Exit Sub
   If lPrevProc = 0& Then
      lPrevProc = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0&, GetCurrentThreadId)
   End If
   Ctl_hWnds(cchWnds) = Ctrl_hWnd
   cchWnds = cchWnds + 1&
End Sub

' Call once to unhook all controls
Public Sub UnhookWheel()
   If lPrevProc Then UnhookWindowsHookEx lPrevProc
   lPrevProc = 0&
   cchWnds = 0&
End Sub

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MouseHookStruct) As Long
   Dim tMsg As Msg
   Dim i As Long
   If Not (nCode < 0&) Then
      If wParam = WM_MOUSEWHEEL Then

         With lParam
            .hWnd = WindowFromPoint(.pt.x, .pt.y)
            Do Until i = cchWnds
                If .hWnd = Ctl_hWnds(i) Then

                   'GetMessage tMsg, .hWnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL
                   'tMsg.wParam > 0  'Wheel Up

                    SetFocus .hWnd
                    Exit Do
                End If
                i = i + 1&
            Loop
         End With
      End If
   End If
   MouseProc = CallNextHookEx(lPrevProc, nCode, wParam, lParam)
End Function

Public Function InTheIDE() As Boolean
    Debug.Assert True Xor DebugOnly(InTheIDE)
End Function

Private Function DebugOnly(bInIDE As Boolean) As Boolean
    bInIDE = True
End Function
