reading mouse wheel rotation in VB6
in [Visual Basic]
|
From: Matthias Immhoff on 5 Mar 2008 19:15 In my eyes there is no good reason for not attaching complex code.
From: Karl E. Peterson on 5 Mar 2008 19:20 Matthias Immhoff wrote: > In my eyes there is no good reason for not attaching complex code. In the eyes of the community, the reasons are countless. -- ..NET: It's About Trust! http://vfred.mvps.org
From: MikeD on 5 Mar 2008 20:52 "Matthias Immhoff" <m.immhoff(a)gmx.de> wrote in message news:OjQ3o8xfIHA.484(a)TK2MSFTNGP06.phx.gbl... > In my eyes there is no good reason for not attaching complex code. Then you need to spend more time in these newsgroups to learn its ettiquette. Again, attachments of any kind are frowned upon, but text file attachments (if relatively small) are "acceptable" as long as it's not abused. Not to be rude, but you're the newcomer. The ettiquette for these newsgroups has been established for quite some time now. If you want to be accepted and welcomed, you're best off following it. -- Mike Microsoft MVP Visual Basic
From: JanAdam on 5 Mar 2008 23:44 Gentlemen, thank you all. Way back, I was quite comfortable with linear programming. Doing other things, I missed OOP development and have been recently trying to get some feel for it by doing a bit of VBA, just for the fun of it. After carefully reading your messages and trying to understand the code you kindly provided, I am likely to follow Mike's suggestion and have somebody doing it. I will play with your code examples just a bit, though. Thanks for the warnings; I will try to be careful. Your giving me your time and advices are all very appreciated. -- JanAdam "Matthias Immhoff" wrote: > Okay, no binary attachments... > Then do the following. > Create a sample project that has 1 form. > Add an empty usercontrol. > Put the code below in the usercontrol, overwriting its current context > completely. > Put the usercontrol on your form. > Make a label and add the following to the form: > > Private Sub ucSubclass1_MouseWheel(ByVal Distance As Integer) > > Static lCount& > lCount = lCount + 1 > > Me.Label1.Caption = "The mouse wheel was triggered for the " & > lCount & ". time." & vbNewLine & "Wheel scrolled up: " & IIf(Distance = > 1, True, False) > > End Sub > '/////////////////////////////////////////////////////// > > Usercontrol code: > '////////////////////////////////////////////////////////// > > Option Explicit > > Public Event MouseEnter() > Public Event MouseLeave() > Public Event MouseWheel(ByVal Distance As Integer) > Public Event Status(ByVal sStatus As String) > > Private Const WM_MOUSEWHEEL As Long = &H20A > Private Const WHEEL_DELTA As Long = 120 ' Default value for rolling one > notch > Private Const WM_MOUSEMOVE As Long = &H200 > Private Const WM_MOUSELEAVE As Long = &H2A3 > Private Const WM_MOVING As Long = &H216 > Private Const WM_SIZING As Long = &H214 > Private Const WM_EXITSIZEMOVE As Long = &H232 > > Private Enum TRACKMOUSEEVENT_FLAGS > TME_HOVER = &H1& > TME_LEAVE = &H2& > TME_QUERY = &H40000000 > TME_CANCEL = &H80000000 > End Enum > > Private Type TRACKMOUSEEVENT_STRUCT > cbSize As Long > dwFlags As TRACKMOUSEEVENT_FLAGS > hwndTrack As Long > dwHoverTime As Long > End Type > > Private bTrack As Boolean > Private bTrackUser32 As Boolean > Private bInCtrl As Boolean > > Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As > Long) As Long > Private Declare Function LoadLibraryA Lib "kernel32" (ByVal > lpLibFileName As String) As Long > Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As > TRACKMOUSEEVENT_STRUCT) As Long > Private Declare Function TrackMouseEventComCtl Lib "Comctl32" Alias > "_TrackMouseEvent" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long > > '================================================================================================== > 'Subclasser declarations > > Private Enum eMsgWhen > MSG_AFTER = 1 > 'Message calls back after the original (previous) WndProc > MSG_BEFORE = 2 > 'Message calls back before the original (previous) WndProc > MSG_BEFORE_AND_AFTER = MSG_AFTER Or MSG_BEFORE > 'Message calls back before and after the original > (previous) WndProc > End Enum > > Private Const ALL_MESSAGES As Long = -1 > 'All messages added or deleted > Private Const GMEM_FIXED As Long = 0 > 'Fixed memory GlobalAlloc flag > Private Const GWL_WNDPROC As Long = -4 > 'Get/SetWindow offset to the WndProc procedure address > Private Const PATCH_04 As Long = 88 > 'Table B (before) address patch offset > Private Const PATCH_05 As Long = 93 > 'Table B (before) entry count patch offset > Private Const PATCH_08 As Long = 132 > 'Table A (after) address patch offset > Private Const PATCH_09 As Long = 137 > 'Table A (after) entry count patch offset > > Private Type tSubData > 'Subclass data type > hWnd As Long > 'Handle of the window being subclassed > nAddrSub As Long > 'The address of our new WndProc (allocated memory). > nAddrOrig As Long > 'The address of the pre-existing WndProc > nMsgCntA As Long > 'Msg after table entry count > nMsgCntB As Long > 'Msg before table entry count > aMsgTblA() As Long > 'Msg after table array > aMsgTblB() As Long > 'Msg Before table array > End Type > > Private sc_aSubData() As tSubData > 'Subclass data array > > Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, > Source As Any, ByVal Length As Long) > Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal > lpModuleName As String) As Long > Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As > Long, ByVal lpProcName As String) As Long > Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As > Long, ByVal dwBytes As Long) As Long > Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) > As Long > Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As > Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long > '================================================================================================== > > 'UserControl events > > 'Read the properties from the property bag - also, a good place to start > the subclassing (if we're running) > Private Sub UserControl_ReadProperties(PropBag As PropertyBag) > With PropBag > 'Read your properties here > 'm_PropName = .ReadProperty("PropName", DEF_PROP_VALUE) > End With > > If Ambient.UserMode Then > 'If we're not in design mode > bTrack = True > bTrackUser32 = IsFunctionExported("TrackMouseEvent", "User32") > > If Not bTrackUser32 Then > If Not IsFunctionExported("_TrackMouseEvent", "Comctl32") Then > bTrack = False > End If > End If > > If bTrack Then > 'OS supports mouse leave so subclass for it > With UserControl > 'Start subclassing the UserControl > Call Subclass_Start(.hWnd) > Call Subclass_AddMsg(.hWnd, WM_MOUSEMOVE, MSG_AFTER) > Call Subclass_AddMsg(.hWnd, WM_MOUSELEAVE, MSG_AFTER) > > 'Start subclassing the Parent form > With .Parent > Call Subclass_Start(.hWnd) > Call Subclass_AddMsg(.hWnd, WM_MOVING, MSG_AFTER) > Call Subclass_AddMsg(.hWnd, WM_SIZING, MSG_AFTER) > Call Subclass_AddMsg(.hWnd, WM_EXITSIZEMOVE, MSG_AFTER) > Call Subclass_AddMsg(.hWnd, WM_MOUSEWHEEL, MSG_AFTER) > End With > End With > End If > End If > End Sub > > Private Sub UserControl_Resize() > > Static inProc As Boolean > If inProc Then Exit Sub > > UserControl.Width = 32 * Screen.TwipsPerPixelX > UserControl.Height = 32 * Screen.TwipsPerPixelY > > inProc = False > > End Sub > > 'The control is terminating - a good place to stop the subclasser > Private Sub UserControl_Terminate() > On Error GoTo Catch > 'Stop all subclassing > Call Subclass_StopAll > Catch: > End Sub > > '====================================================================================================== > 'UserControl private routines > > 'Determine if the passed function is supported > Private Function IsFunctionExported(ByVal sFunction As String, ByVal > sModule As String) As Boolean > Dim hMod As Long > Dim bLibLoaded As Boolean > > hMod = GetModuleHandleA(sModule) > > If hMod = 0 Then > hMod = LoadLibraryA(sModule) > If hMod Then > bLibLoaded = True > End If > End If > > If hMod Then > If GetProcAddress(hMod, sFunction) Then > IsFunctionExported = True > End If > End If > > If bLibLoaded Then > Call FreeLibrary(hMod) > End If > End Function > > 'Track the mouse leaving the indicated window > Private Sub TrackMouseLeave(ByVal lng_hWnd As Long) > Dim tme As TRACKMOUSEEVENT_STRUCT > > If bTrack Then > With tme > .cbSize = Len(tme) > .dwFlags = TME_LEAVE > .hwndTrack = lng_hWnd > End With > > If bTrackUser32 Then > Call TrackMouseEvent(tme) > Else > Call TrackMouseEventComCtl(tme) > End If > End If > End Sub > > '====================================================================================================== > 'Subclass handler - MUST be the first Public routine in this file. That > includes public properties also > > Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As > Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As > Long, ByRef wParam As Long, ByRef lParam As Long) > 'Parameters: > 'bBefore - Indicates whether the the message is being processed > before or after the default handler - only really needed if a message is > set to callback both before & after. > 'bHandled - Set this variable to True in a 'before' callback to > prevent the message being subsequently processed by the default > handler... and if set, an 'after' callback > 'lReturn - Set this variable as per your intentions and > requirements, see the MSDN documentation for each individual message value. > 'hWnd - The window handle > 'uMsg - The message number > 'wParam - Message related data > 'lParam - Message related data > 'Notes: > 'If you really know what you're doing, it's possible to change the > values of the > 'hWnd, uMsg, wParam and lParam parameters in a 'before' callback so > that different > 'values get passed to the default handler.. and optionaly, the > 'after' callback > Static bMoving As Boolean > > Select Case uMsg > Case WM_MOUSEMOVE > If Not bInCtrl Then > bInCtrl = True > Call TrackMouseLeave(lng_hWnd) > RaiseEvent MouseEnter > End If > > Case WM_MOUSELEAVE > bInCtrl = False > RaiseEvent MouseLeave > > Case WM_MOVING > bMoving = True > RaiseEvent Status("Form is moving...") > > Case WM_SIZING > bMoving = False > RaiseEvent Status("Form is sizing...") > > Case WM_EXITSIZEMOVE > RaiseEvent Status("Finished " & IIf(bMoving, "moving.", "sizing.")) > > Case WM_MOUSEWHEEL > Dim Distance As Long > Dim yPos As Long > Dim xPos As Long > > Distance = HighWord(wParam) \ WHEEL_DELTA > > RaiseEvent MouseWheel(Distance)
From: Matthias Immhoff on 6 Mar 2008 04:56
JanAdam schrieb: > Gentlemen, thank you all. > Way back, I was quite comfortable with linear programming. Doing other > things, I missed OOP development and have been recently trying to get some > feel for it by doing a bit of VBA, just for the fun of it. After carefully > reading your messages and trying to understand the code you kindly provided, > I am likely to follow Mike's suggestion and have somebody doing it. I will I already did it for you, what's the problem. |