For Speedy, or for anyone: Mouse Wheel button

[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.

Form code...

Option Explicit

Private Sub Form_Load()
    Call Hook
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call Unhook
End Sub

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

I've been looking for code like this to add to my collection!

[James Stanich]

I forgot I asked before.

Yonatan, how would I mimic and up/down scroll on a grid or combobox?