How to Detect whether the Scroll Button in a Mouse is Scrolled...

[Matthew Gates]

Try this:

'Author: Yonatan
'Origin: [url]http://www.vbforums.com/[/url]
'Purpose: Detect Mouse Wheel
'Version: VB5+ 
'Message from Yonatan: 
'-Here's some way to use the mouse Wheel Button. 
'-It uses Subclassing, so be extra careful...  
'-It also uses CopyMemory to quickly calculate LoWords and 
'-HiWords where needed. 
'-You need a Module and a Form called Form1 for this code. 
'-To test it, rotate and click the Wheel button on the Form, and
'-watch the Immediate window for results! (If it's not there, hit 
'-Ctrl+G and it will appear.) 
'-The entire code is in the module, if you need to change it. 
 
 
'Module Code:
 
Option Explicit
 
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 Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbSrc As Long)
 
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const MK_LBUTTON = &H1
Private Const MK_RBUTTON = &H2
Private Const MK_SHIFT = &H4
Private Const MK_CONTROL = &H8
Private Const MK_MBUTTON = &H10
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
 
Private lpPrevWndProc As Long
 
Function LoWord(ByVal dwDoubleWord As Long) As Integer
    Call CopyMemory(LoWord, dwDoubleWord, 2)
End Function
 
Function HiWord(ByVal dwDoubleWord As Long) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(dwDoubleWord) + 2, 2)
End Function
 
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim fwKeys As Integer, zDelta As Integer, sMsg As String
    Select Case uMsg
    Case WM_MBUTTONDOWN
        sMsg = "The Wheel button is down!"
    Case WM_MBUTTONUP
        sMsg = "The Wheel button isn't down anymore!"
    Case WM_MBUTTONDBLCLK
        sMsg = "The Wheel button has been double-clicked!"
    Case WM_MOUSEWHEEL
        fwKeys = LoWord(wParam)
        zDelta = HiWord(wParam) / WHEEL_DELTA
        sMsg = "Wheel rotated " & Abs(zDelta) & " ticks " & IIf(zDelta > 0, "forward!", "backward!")
        If (fwKeys And MK_LBUTTON) = MK_LBUTTON Then sMsg = sMsg & vbNewLine & "The left button was down!"
        If (fwKeys And MK_RBUTTON) = MK_RBUTTON Then sMsg = sMsg & vbNewLine & "The right button was down!"
        If (fwKeys And MK_SHIFT) = MK_SHIFT Then sMsg = sMsg & vbNewLine & "The shift key was down!"
        If (fwKeys And MK_CONTROL) = MK_CONTROL Then sMsg = sMsg & vbNewLine & "The ctrl key was down!"
        If (fwKeys And MK_MBUTTON) = MK_MBUTTON Then sMsg = sMsg & vbNewLine & "The Wheel button was down!"
    End Select
    If Len(sMsg) > 0 Then Debug.Print sMsg
    WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function
 
Public Sub Hook()
    lpPrevWndProc = SetWindowLong(Form1.hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
 
Public Sub Unhook()
    Call SetWindowLong(Form1.hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
 
 
'Form Code:
 
Private Sub Form_Load()
    Call Hook
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call Unhook
End Sub