VB6 Mouse Scrollen im Datagrid

'------------------------Allgemeiner Teil  
Private WithEvents Msg As MsgHook
'-------------------------------------------  
'Formaufruf  
  Set Msg = New MsgHook
  Msg.Hook Me.hWnd, WM_MOUSEWHEEL

Option Explicit

Private Const GWL_WNDPROC = -4
Private Const MAX_HASH = 257

Private Type typHook
  hWnd As Long
  MsgHookPtr As Long
  ProcAddr As Long
  WndProc As Long
  uMsgCount As Long
  uMsg(MAX_HASH - 1) As Boolean
  uMsgCol As Collection
End Type

Private Declare Function CallWindowProcA Lib "user32" ( _  
    ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _
    ByVal Msg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _  
    (dest As Any, source As Any, ByVal NumBytes As Long)
Private Declare Function SetWindowLongA Lib "user32" ( _  
    ByVal hWnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Const MAXHOOKS = 9
Private Initialized As Boolean
Private arrHook() As typHook
Private NrCol As Collection
'---------'---------'---------'---------'---------'---------'---------  

Public Function DoHook(ByVal ObjPtr As Long, ByVal hWnd As Long, _
    uMsg As Variant) As Long
  Dim i As Long
  Dim j As Long
  
  If Not Initialized Then
    ReDim Preserve arrHook(1 To MAXHOOKS)
    arrHook(1).WndProc = Addr2Long(AddressOf WndProc1)
    arrHook(2).WndProc = Addr2Long(AddressOf WndProc2)
    arrHook(3).WndProc = Addr2Long(AddressOf WndProc3)
    arrHook(4).WndProc = Addr2Long(AddressOf WndProc4)
    arrHook(5).WndProc = Addr2Long(AddressOf WndProc5)
    arrHook(6).WndProc = Addr2Long(AddressOf WndProc6)
    arrHook(7).WndProc = Addr2Long(AddressOf WndProc7)
    arrHook(8).WndProc = Addr2Long(AddressOf WndProc8)
    arrHook(9).WndProc = Addr2Long(AddressOf WndProc9)
    Set NrCol = New Collection
    Initialized = True
  End If
  
  'Hook-Nr suchen:  
  For i = 1 To UBound(arrHook)
    If arrHook(i).MsgHookPtr = 0 Then Exit For
  Next i
  If i > UBound(arrHook) Then
    ReDim Preserve arrHook(1 To 2 * UBound(arrHook))
  End If
  If i > MAXHOOKS Then
    NrCol.Add i, "H" & hWnd  
    arrHook(i).WndProc = Addr2Long(AddressOf WndProcX)
  End If
  DoHook = i
  
  'Hook einrichten:  
  arrHook(i).uMsgCount = UBound(uMsg) + 1
  If arrHook(i).uMsgCount Then
    Erase arrHook(i).uMsg
    Set arrHook(i).uMsgCol = New Collection
    For j = LBound(uMsg) To UBound(uMsg)
      arrHook(i).uMsg(uMsg(j) Mod MAX_HASH) = True
      arrHook(i).uMsgCol.Add True, "H" & uMsg(j)  
    Next j
  End If
  arrHook(i).hWnd = hWnd
  arrHook(i).MsgHookPtr = ObjPtr
  arrHook(i).ProcAddr = _
      SetWindowLongA(hWnd, GWL_WNDPROC, arrHook(i).WndProc)
End Function

Public Sub DoUnhook(ByVal Nr As Long)
  If Nr Then
    With arrHook(Nr)
      SetWindowLongA .hWnd, GWL_WNDPROC, .ProcAddr
      .MsgHookPtr = 0
      Erase .uMsg
      Set .uMsgCol = Nothing
      If Nr > MAXHOOKS Then NrCol.Remove "H" & .hWnd  
    End With
''    If (Nr <= MAXHOOKS) And (NrCol.Count > 0) Then  
''      'Ggf. garbage collection?! / optimieren  
''    End If  
  End If
End Sub

Public Function WndProc(ByVal Nr As Long, ByVal hWnd As Long, _
    ByVal uMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
  Dim oMsgHook As MsgHook
  Dim retVal As Long
  Dim Ok As Boolean
  
  With arrHook(Nr)
    If .uMsgCount > 0 Then
      If .uMsg(uMsg Mod MAX_HASH) Then
        On Error Resume Next
          Ok = .uMsgCol("H" & uMsg) And (Err = 0)  
        On Error GoTo 0
      End If
    Else
      Ok = True
    End If
    If Ok Then
      CopyMemory oMsgHook, .MsgHookPtr, 4
      oMsgHook.RaiseBefore uMsg, wParam, lParam, retVal
      If uMsg Then
        retVal = CallWindowProcA(.ProcAddr, hWnd, uMsg, wParam, lParam)
        oMsgHook.RaiseAfter uMsg, wParam, lParam
      End If
      CopyMemory oMsgHook, 0&, 4
    Else
      retVal = CallWindowProcA(.ProcAddr, hWnd, uMsg, wParam, lParam)
    End If
  End With
  WndProc = retVal
End Function

Public Function WndProc1(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc1 = WndProc(1, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc2(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc2 = WndProc(2, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc3(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc3 = WndProc(3, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc4(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc4 = WndProc(4, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc5(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc5 = WndProc(5, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc6(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc6 = WndProc(6, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc7(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc7 = WndProc(7, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc8(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc8 = WndProc(8, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProc9(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  WndProc9 = WndProc(9, hWnd, uMsg, wParam, lParam)
End Function

Public Function WndProcX(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim Nr As Long
On Error Resume Next
  Nr = NrCol("H" & hWnd)  
On Error GoTo 0
  If Nr Then WndProcX = WndProc(Nr, hWnd, uMsg, wParam, lParam)
End Function
'---------'---------'---------'---------'---------'---------'---------  

Private Function Addr2Long(ByVal Addr As Long) As Long
  Addr2Long = Addr
End Function

Option Explicit

Public Enum WM_CONST
    WM_MOUSEWHEEL = &H20A
End Enum

Public Event After(ByRef uMsg As Long, ByRef wParam As Long, _
    ByRef lParam As Long)
Public Event Before(ByRef uMsg As Long, ByRef wParam As Long, _
    ByRef lParam As Long, ByRef retVal As Long)

Private Nr As Long
'---------'---------'---------'---------'---------'---------'---------  

Public Sub Hook(ByVal hWnd As Long, ParamArray uMsg() As Variant)
  Dim i As Long
  Dim v As Variant
  
  If Nr Then DoUnhook Nr
  v = uMsg
  Nr = DoHook(ObjPtr(Me), hWnd, v)
End Sub

Public Sub RaiseAfter(ByRef uMsg As Long, _
    ByRef wParam As Long, ByRef lParam As Long)
  RaiseEvent After(uMsg, wParam, lParam)
End Sub

Public Sub RaiseBefore(ByRef uMsg As Long, _
    ByRef wParam As Long, ByRef lParam As Long, ByRef retVal As Long)
  RaiseEvent Before(uMsg, wParam, lParam, retVal)
End Sub

Public Sub Unhook()
  DoUnhook Nr
  Nr = 0
End Sub
'---------'---------'---------'---------'---------'---------'---------  

Private Sub Class_Terminate()
  If Nr Then DoUnhook Nr
End Sub