Attribute VB_Name = "MouseScrolling"
Option Explicit

Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex&)
Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Declare Function SystemParametersInfo& Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction&, ByVal uParam&, ByRef lpvParam As Any, ByVal fuWinIni&)

Public ScrollBarIndex As Integer

Public wheel_msg_id As Long           'Message ID für MouseWheel-Ereignisse

Private active_hook As Long          'vermeidet doppelten Aufruf von Hook/Unhook
Private oldWinFunc As Long           'ursprüngliche Prozedur zur Message-Verarbeitung
Private wheel_support As Long      'gibt es überhaupt MouseWheel-Unterstützung
Private wheel_native_support As Long 'unterstützt OS MouseWheel?
Private wheel_scr_lines As Long 'Zahl der Scroll-Lines (je 120)

' diese Funktion ermittelt
' (1) ob MouseWheel überhaupt unterstützt wird     ---> wheel_support
' (2) ob MouseWheel direkt vom OS unterstützt wird ---> wheel_native_support
' (3) den ID der MouseWheel-Messages               ---> wheel_msg_id
' (4) die Anzahl der Zeilen je Impuls              ---> wheel_scr_lines
Public Sub Setup_MsWheel()
  Const SM_MouseWheelPresent = 75
  Const SPI_GetWheelScrollLines = 104  'nur für NT4/Win98
  Const WM_MouseWheel = &H20A          'nur für NT4/Win98
  Dim wheel_scrl_msg  As Long
  
  wheel_native_support = GetSystemMetrics(SM_MouseWheelPresent)
  If wheel_native_support Then
    ' message ID ist durch OS vorgegeben (WinNT >= 4 and Win >= 98)
    wheel_support = True
    wheel_msg_id = WM_MouseWheel  '&H20A
    SystemParametersInfo SPI_GetWheelScrollLines, 0, wheel_scr_lines, 0
  
  Else
    ' keine direkte OS-Unterstützung
    ' stellt fest, ob IntelliMouse durch OS-Erweiterung unterstützt wird
    wheel_support = FindWindow("MouseZ", "Magellan MSWHEEL")
    If wheel_support Then
      ' message ID wird dynamisch ermittelt
      wheel_msg_id = RegisterWindowMessage("MSWHEEL_ROLLMSG")
      ' wheel_scr_lines wird dynamisch ermittelt
      wheel_scrl_msg = RegisterWindowMessage("MSH_SCROLL_LINES_MSG")
      If wheel_scrl_msg Then
        wheel_scr_lines = SendMessageA(wheel_support, wheel_scrl_msg, 0, 0)
      Else
        ' Defaultwert für wheel_scr_lines
        wheel_scr_lines = 3
      End If
    End If
  End If
End Sub

Public Function MouseScrollProc(ByVal hw&, ByVal uMsg&, ByVal WParam&, ByVal lParam&) As Long
  Dim X  As Long
  Dim Y  As Long
  Dim Button  As Long
  Dim delta As Long
  Dim newvalue As Long
  Static deltasum As Double
  
  On Error Resume Next
  If wheel_native_support Then
    Button = LoWord(WParam)        'Tasten (Shift=4, Strg=8 etc.)
    delta = HiWord(WParam)        'Bewegung des Rads
  Else
    delta = LoWord(WParam)        'Bewegung des Rads (vorzeichenrichtig --> Mod)
    Button = 0                    'leider keine Tasteninfo unter Win 95
  End If
  
  X = LoWord(lParam)              'x und y-Koordinate in Screen-Pixel absolut
  Y = HiWord(lParam)
  ' Reaktion auf Ereignis
  With IIf(ScrollBarIndex = 0, Form1.UlistScr, Form1.VScroll1)
    If wheel_scr_lines = -1 Then  'seitenweise
      newvalue = .Value - .LargeChange * Sgn(delta)
    Else
      'zeilenweise
      ' Veränderungen aufsummieren, bis 1 überschritten wird
      deltasum = deltasum + .SmallChange * (delta / 120 * wheel_scr_lines)
      If Abs(deltasum) >= 1 Then
        newvalue = .Value - Fix(deltasum)
        deltasum = deltasum - Fix(deltasum)
      Else
        newvalue = .Value
      End If
    End If
    If newvalue > .Max Then newvalue = .Max
    If newvalue < .Min Then newvalue = .Min
    .Value = newvalue
  End With
End Function

' Long-Zahl in zwei Int-Zahlen zerlegen
Public Function HiWord(ByVal X As Long) As Integer
  HiWord = (X And &HFFFF0000) \ &H10000
End Function

Public Function LoWord(ByVal X As Long) As Integer
  X = X And &HFFFF&
  If X > 32767 Then
    LoWord = X - 65536
  Else
    LoWord = X
  End If
End Function



