This all dovetails in with my work done here. However, this post is complete. I mention my other "general" subclassing post as I tend to keep all my subclassing in one module, and the work here is done in such a way that it could be easily woven in with the work in that "general" subclassing post.
Here's the code for doing subclassing to detect mouse wheel actions (must be in BAS module):
Code:
Option Explicit
'
Public ProhibitSubclassing As Boolean ' Just in case we want to suppress any/all of our subclassing.
'
Private ProgramIsRunning As Boolean ' Used when in IDE to try and detect "Stop" button being clicked.
'
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32.dll" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any)
Private Declare Sub GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any)
' Here are a few places to get the windows message pump constants:
' https://wiki.winehq.org/List_Of_Windows_Messages
' https://www.autoitscript.com/autoit3/docs/appendix/WinMsgCodes.htm
' https://gist.github.com/amgine/2395987
' https://www.autohotkey.com/docs/v2/misc/SendMessageList.htm
' NOTE: So long as you exit your program normally (including within the IDE), this will be IDE safe.
' However, if you use the "Stop" button, or you click "End" on a syntax error, you will crash the IDE.
' There are approaches to make subclassing completely safe for the IDE, but they're more involved.
'
Public Sub SubclassForMouseWheel(TheForm As Form, TheControl As Object)
' For mouse-wheel subclassing.
' TheControl can also just be the form if you want to detect mouse on entire form.
' It must be a control with a hWnd.
'
SubclassSomeWindow TheControl.hWnd, AddressOf MouseWheel_Proc, ObjPtr(TheForm)
End Sub
Private Function MouseWheel_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Const WM_DESTROY As Long = &H2&
'
' For mouse-wheel subclassing.
If uMsg = WM_DESTROY Then
UnSubclassSomeWindow hWnd, AddressOf_MouseWheel_Proc
MouseWheel_Proc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
Exit Function
End If
If Not ProgramIsRunning Then ' Protect the IDE. Don't execute any specific stuff if we're stopping. We may run into COM objects or other variables that no longer exist.
MouseWheel_Proc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
Exit Function
End If
'
Const WM_MOUSEWHEEL As Long = &H20A&
Const WM_MOUSEHWHEEL As Long = &H20E&
'
If uMsg = WM_MOUSEWHEEL Or uMsg = WM_MOUSEHWHEEL Then
Dim ShiftBitFlags As Integer ' 0x0001=left-button, 0x0002=right-button, 0x0004=shift, 0x0008=ctrl, 0x0010=middle-button, 0x0020=XButton1, 0x0040=XButton2.
Dim ScreenXPixels As Integer ' Where on the screen the mouse is.
Dim ScreenYPixels As Integer ' Where on the screen the mouse is.
Dim WheelDeltaTicks As Integer ' A magnitude indicator for this event.
Dim Horizontal As Boolean ' Indicates scroll wheel is tilted left-or-right.
Dim LeftOrRight As Integer ' Only non-zero if Horizontal is true: -1 = LEFT, 1 = RIGHT.
Dim BackScroll As Boolean ' Indicates a vertical backward scroll (not used if Horizontal=True).
GetMem2 wParam, ShiftBitFlags
GetMem2 ByVal VarPtr(wParam) + 2&, WheelDeltaTicks
If WheelDeltaTicks < 0 Then WheelDeltaTicks = -WheelDeltaTicks
GetMem2 lParam, ScreenXPixels
GetMem2 ByVal VarPtr(lParam) + 2&, ScreenYPixels
Select Case uMsg
Case WM_MOUSEWHEEL: BackScroll = wParam < 0&
Case WM_MOUSEHWHEEL: Horizontal = True: LeftOrRight = Sgn(wParam)
End Select
Dim objStolen As Object
Dim frm As Object
GetMem4 dwRefData, objStolen ' Steal reference.
Set frm = objStolen ' Make good reference.
GetMem4 0&, objStolen ' Un-steal reference.
On Error Resume Next ' Protect ourselves in case the PUBLIC procedure isn't found in the form.
Call frm.Form_MouseWheel(hWnd, ShiftBitFlags, ScreenXPixels, ScreenYPixels, WheelDeltaTicks, Horizontal, LeftOrRight, BackScroll)
'
' Example of procedure declaration in form (MUST be Public):
' Public Sub Form_MouseWheel(ControlHwnd As Long, ShiftBitFlags As Integer, ScreenXPixels As Integer, ScreenYPixels As Integer, WheelDeltaTicks As Integer, Horizontal As Boolean, LeftOrRight As Integer, BackScroll As Boolean)
'
On Error GoTo 0
Exit Function ' We stop the chain since we processed the message.
End If
'
MouseWheel_Proc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function
Private Function AddressOf_MouseWheel_Proc() As Long
' For mouse-wheel subclassing.
AddressOf_MouseWheel_Proc = ProcedureAddress(AddressOf MouseWheel_Proc)
End Function
' ************************************************************
' ************************************************************
' A few private procedures to try and simplify things a bit.
' ************************************************************
' ************************************************************
Private Sub SubclassSomeWindow(hWnd As Long, AddressOf_ProcToSubclass As Long, Optional dwRefData As Long, Optional uIdSubclass As Long)
If ProhibitSubclassing Then Exit Sub
ProgramIsRunning = True
If uIdSubclass = 0& Then uIdSubclass = hWnd
Call SetWindowSubclass(hWnd, AddressOf_ProcToSubclass, uIdSubclass, dwRefData)
End Sub
Private Sub UnSubclassSomeWindow(hWnd As Long, AddressOf_ProcToSubclass As Long, Optional uIdSubclass As Long)
If ProhibitSubclassing Then Exit Sub
If uIdSubclass = 0& Then uIdSubclass = hWnd
Call RemoveWindowSubclass(hWnd, AddressOf_ProcToSubclass, uIdSubclass)
End Sub
Private Function GetSubclassRefData(hWnd As Long, AddressOf_ProcToSubclass As Long, Optional uIdSubclass As Long) As Long
If ProhibitSubclassing Then Exit Function
If uIdSubclass = 0& Then uIdSubclass = hWnd
Call GetWindowSubclass(hWnd, AddressOf_ProcToSubclass, uIdSubclass, GetSubclassRefData)
End Function
Private Function IsSubclassed(hWnd As Long, AddressOf_ProcToSubclass As Long, Optional uIdSubclass As Long) As Boolean
If ProhibitSubclassing Then Exit Function
Dim dwRefData As Long
If uIdSubclass = 0& Then uIdSubclass = hWnd
IsSubclassed = GetWindowSubclass(hWnd, AddressOf_ProcToSubclass, uIdSubclass, dwRefData) = 1&
End Function
Private Function ProcedureAddress(AddressOf_TheProc As Long) As Long
ProcedureAddress = AddressOf_TheProc
End Function
Code:
Option Explicit
Private Sub Form_Load()
SubclassForMouseWheel Me, Picture1
End Sub
Public Sub Form_MouseWheel(ControlHwnd As Long, ShiftBitFlags As Integer, ScreenXPixels As Integer, ScreenYPixels As Integer, WheelDeltaTicks As Integer, Horizontal As Boolean, LeftOrRight As Integer, BackScroll As Boolean)
Debug.Print "----------------------------------"
Debug.Print "hWnd of scrolling control: "; ControlHwnd ' Allows us to subclass scrolling on multiple controls on a form, if so desired.
Debug.Print "Shift bits: "; Hex$(ShiftBitFlags)
Debug.Print "X & Y", ScreenXPixels, ScreenYPixels
Debug.Print "Ticks: "; WheelDeltaTicks
If Horizontal Then
Debug.Print "Horizontal left or right: "; LeftOrRight
Else
Debug.Print "Back scroll: "; BackScroll
End If
End Sub
I'm not going to attach a project, as I truly believe someone should be able to copy-paste this easy enough if they're going to use subclassing.
Enjoy. :)