' Die benötigten API-Funktionen
Private Declare Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" ( _
  ByVal Hwnd As Long, _
  ByVal nIndex As Long, _
  ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
  Alias "CallWindowProcA" ( _
  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" ( _
  pDst As Any, pSrc As Any, ByVal ByteLen As Long)
 
' Konstante zur Auswertung des Wheel-Events
Private Const MK_CONTROL = &H8  ' (Strg-Taste gedrückt)
Private Const MK_LBUTTON = &H1  ' (linke Maustaste gedrückt)
Private Const MK_RBUTTON = &H2  ' (rechte Maustaste gedrückt)
Private Const MK_MBUTTON = &H10 ' (Wheel gedrückt)
Private Const MK_SHIFT = &H4    ' (Shift-Taste gedrückt)
 
' Konstante für das subclassing
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A
 
' Merkvariable für die Addresse der Windowprozedur
Private oldWndProc As Long
 
Public Sub SetSubClass(ByVal Hwnd As Long)
  oldWndProc = SetWindowLong(Hwnd, GWL_WNDPROC, _
    AddressOf WndProc)
End Sub
 
Private Function LoWord(ByRef uParam As Long) As Long
  Dim N As Long
 
  N = 0
  CopyMemory ByVal VarPtr(N), ByVal VarPtr(uParam), 2
  LoWord = N
End Function
 
Public Function WndProc(ByVal Hwnd As Long, _
  ByVal uMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long
 
  Dim nValue As Long
  Dim nEvent As Long
  Dim x As Long
  Dim y As Long
 
  ' Alle Messages durchlassen bis auf WM_MOUSEWHEEL!
  If uMsg = WM_MOUSEWHEEL Then
    ' Mausrad wurde gedreht!
 
    nValue = HiWord(wParam)
    nEvent = LoWord(wParam)
    x = LoWord(lParam)
    y = HiWord(lParam)
 
    If wParam < 0 Then
     SendKeys "{down}"
    Else
     SendKeys "{up}"
    End If
    Exit Function
  End If
 
  WndProc = CallWindowProc(oldWndProc, Hwnd, uMsg, _
     wParam, ByVal lParam)
End Function
 
Private Function HiWord(ByRef uParam As Long) As Long
  Dim N As Long
 
  N = 0
  CopyMemory ByVal VarPtr(N), ByVal VarPtr(uParam) + 2, 2
  HiWord = N
End Function
 
Public Sub UnSetSubClass(ByVal Hwnd As Long)
  SetWindowLong Hwnd, GWL_WNDPROC, oldWndProc
End Sub