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...
Module code...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
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





Reply With Quote