reading mouse wheel rotation in VB6
in [Visual Basic]
|
From: MikeD on 5 Mar 2008 17:21 "Matthias Immhoff" <m.immhoff(a)gmx.de> wrote in message news:%23dSxp5wfIHA.1132(a)TK2MSFTNGP06.phx.gbl... > You must subclass. I attached a sample, I think it's convenient. > Cheers! No binary attachments in here please. Any attachment is frowned upon here, but if you must make an attachment(s), ONLY attach text files. -- Mike Microsoft MVP Visual Basic
From: Lorin on 5 Mar 2008 17:39 Try http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=67440&lngWId=1 "JanAdam" wrote: > How to read mouse wheel rotation in VB6? > I am not a programmer. I need to control a step motor from a computer via a > serial port. I am trying to write a code to move the motor one way or another > by using a mouse wheel, when a mouse cursor is placed on a control button on > a form. I know the protocol for the motor controller. I need to read the > number of wheel steps and direction of the wheel rotation. I know how to make > the form responding to clicking on the button, but do not know how to make it > responding to the wheel rotation. WM_MOUSEWHEEL notification gives me all > that I need but I do not know how to use it in my control button code in VB6. > Any help will be greatly appreciated. > > -- > JanAdam
From: Karl E. Peterson on 5 Mar 2008 17:55 JanAdam wrote: > Karl, no need for sarcasm. Sorry. > I did Google before posting. Most relevant postings I found deal with using > the wheel in IDE. Some are written in languages I do not know. Some are by > far too advanced for me as I only have a rudimentary knowledge of VB. That's gonna be an issue, then. I'm not aware of any really easy ways to get at that message without directly subclassing windows in your app for it. It's not difficult code, but it's definitely not double-click, point, drag, etc. > tried to use the code in http://www.adit.co.uk/html/mousewheelsupport.htmlf > but run into problems with type declarations. I only posted my question > because I need some help. Ya gotta admit, it was a pretty wide open question. This narrows it down quite a bit. The more specific you are, the more so we can be too. -- ..NET: It's About Trust! http://vfred.mvps.org
From: BeastFish on 5 Mar 2008 18:38 "JanAdam" <JanAdam(a)discussions.microsoft.com> wrote in message news:4F1CDAC9-BA1C-44AF-9C1A-DCE53E15368B(a)microsoft.com... > How to read mouse wheel rotation in VB6? > I am not a programmer. I need to control a step motor from a computer via a > serial port. I am trying to write a code to move the motor one way or another > by using a mouse wheel, when a mouse cursor is placed on a control button on > a form. I know the protocol for the motor controller. I need to read the > number of wheel steps and direction of the wheel rotation. I know how to make > the form responding to clicking on the button, but do not know how to make it > responding to the wheel rotation. WM_MOUSEWHEEL notification gives me all > that I need but I do not know how to use it in my control button code in VB6. > Any help will be greatly appreciated. VB forms, controls, et al don't natively handle mouse scroll messages, so you're going to have to do some subclassing (hook into the windows messages and look for WM_MOUSEWHEEL yourself). Since command buttons have a handle (hWnd), you can hook into the particular command button. But I would probably hook the form itself and just check if the mouse is over the desired button. Here's a quick and dirty sample (just did some quick copy/paste-ing, so it could likely be better). For a non-programmer, this is enough to make you dangerous :-) So don't try to incorporate it into the main project until you understand it... what's going on. Put this into a "test" project first. Fair warning... since it involves subclassing, DO NOT use the IDE's "stop" button (or the End statement in code), close the form so it's Unload event executes or it will explode! Also, please watch for any wordwrapping in the code below... Start a new, fresh VB6 project. On the form, place a command button and paste this code into the form's (General)(Declarations)... ===================================================== Private Sub Form_Load() Call HasWheelScroll ' "register" handle of control for scroll messages HandleForScroll = Command1.hwnd ' Store handle of the hooked winder HookedHandle = Form1.hwnd ' Start capturing messages for it Call Hook End Sub Private Sub Form_Unload(Cancel As Integer) ' Stop hookin' (* very important *) Call Unhook End Sub ===================================================== Not too bad, eh? But wait, there's more. Now open a new Bas module (subclassing needs to be done in a bas module), and paste this code into the module's (General)(Declarations)... ===================================================== Option Explicit 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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Const GWL_WNDPROC = -4 Public lpPrevWndProc As Long Public HookedHandle As Long ' Mouse scrollwheel Private Const WM_MOUSEWHEEL = &H20A Private Const WM_VSCROLL = &H115 Private Const WHEEL_DELTA = 120 ' Mouse Scrollwheel init Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Integer) As Integer Private Declare Function SystemParametersInfo _ Lib "user32" Alias "SystemParametersInfoA" _ (ByVal uAction As Long, ByVal uParam As Long, _ ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long Private Const SM_MOUSEWHEELPRESENT = 75 Private Const SPI_GETWHEELSCROLLLINES = 104 Private WheelScrollLines As Long ' Iz mouse over "registered" control stuff Public HandleForScroll As Long Private Type POINTAPI X As Long Y As Long End Type Private Declare Function GetCursorPos Lib "user32" _ (lpPoint As POINTAPI) As Long Private Declare Function WindowFromPoint Lib "user32" _ (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private wPt As POINTAPI Public Sub Hook() lpPrevWndProc = SetWindowLong(HookedHandle, _ GWL_WNDPROC, _ AddressOf WindowProc) End Sub Public Sub Unhook() Call SetWindowLong(HookedHandle, _ GWL_WNDPROC, _ lpPrevWndProc) End Sub Public Sub HasWheelScroll() ' See if da mousie has a scroll wheel If GetSystemMetrics(SM_MOUSEWHEELPRESENT) <> 0 Then ' Yup, it does If SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, WheelScrollLines, 0) = 0 Then ' Didn't retrieve a value, so use a default value WheelScrollLines = 3 End If Else ' No mouse wheel present WheelScrollLines = 0 End If End Sub Function WindowProc(ByVal hw As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long ' Handle mousewheel scroll messages If uMsg = WM_MOUSEWHEEL Then ' Iz mousie on "registered" control/winder Call GetCursorPos(wPt) If WindowFromPoint(wPt.X, wPt.Y) = HandleForScroll Then Dim ScrollDistance As Long ScrollDistance = wParam \ &H10000 \ WHEEL_DELTA If ScrollDistance > 0 Then Debug.Print "Scroll - " & CStr(Abs(ScrollDistance) * WheelScrollLines) Else Debug.Print "Scroll + " & CStr(Abs(ScrollDistance) * WheelScrollLines) End If End If End If ' Pass message on to the original window message handler WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam) End Function ===================================================== Now, save your project as a test project. Then run it, move the mouse over the command button and scroll to your heart's content, look at the IDE's intermediate window (debug winder). Remember, this is enough to cause havoc and anarchy for someone that doesn't quite understand what's going on. So don't throw this into the actual project until you're comfortable with it and have some understanding of what it's doing... do it as a test or sample project first. Quick and dirty explaination of the subclassing... The Hook sub starts it off by specifying which window to intercept messages for and where to re-direct those messages (WindowProc, as specified with AddressOf). The WindowProc function is where all the messages for that window are now flowing through, where you can check for a particular message and act accordingly (in this case, the WM_MOUSEWHEEL message). The last line in WindowProc sends all the messages back to the normal message handler. The Unhook sub stops the subclassing, resets it back to "normal" (which is important unless you like GPFs et al). Have fun.
From: Matthias Immhoff on 5 Mar 2008 19:12
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) End Select End Sub '====================================================================================================== 'Subclass code - The programmer may call any of the following Subclass_??? routines 'Add a message to the table of those that will invoke a callback. You should Subclass_Start first and then add the messages Private Sub Subclass_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER) 'Parameters: 'lng_hWnd - The handle of the window for which the uMsg is to be added to the callback table 'uMsg - The message number that will invoke a callback. NB Can also be ALL_MESSAGES, ie all messages will callback 'When - Whether the msg is to callback before, after or both with respect to the the default (previous) handler With sc_aSubData(zIdx(lng_hWnd)) If When And eMsgWhen.MSG_BEFORE Then Call zAddMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, ..nAddrSub) End If If When And eMsgWhen.MSG_AFTER Then Call zAddMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, ..nAddrSub) End If End With End Sub 'Delete a message from the table of those that will invoke a callback. Private Sub Subclass_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER) 'Parameters: 'lng_hWnd - The handle of the window for which the uMsg is to be removed from the callback table 'uMsg - The message number that will be removed from the callback table. NB Can also be ALL_MESSAGES, ie all messages will callback 'When - Whether the msg is to be removed from the before, after or both callback tables With sc_aSubData(zIdx(lng_hWnd)) If When And eMsgWhen.MSG_BEFORE Then Call zDelMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, ..nAddrSub) End If If When And eMsgWhen.MSG_AFTER Then Call zDelMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, ..nAddrSub) End If End With End Sub 'Return whether we're running in the IDE. Private Function Subclass_InIDE() As Boolean Debug.Assert zSetTrue(Subclass_InIDE) End Function 'Start subclassing the passed window handle Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long 'Parameters: 'lng_hWnd - The handle of the window to be subclassed 'Returns; 'The sc_aSubData() index Const CODE_LEN As Long = 200 'Length of the machine code in bytes Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc Const FUNC_EBM As String = "EbMode" 'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint Const FUNC_SWL As String = "SetWindowLongA" 'SetWindowLongA allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped Const MOD_USER As String = "user32" 'Location of the SetWindowLongA & CallWindowProc functions Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5 Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6 Const PATCH_01 As Long = 18 'Code buffer offset to the location of the relative address to EbMode Const PATCH_02 As Long = 68 'Address of the previous WndProc Const PATCH_03 As Long = 78 'Relative address of SetWindowsLong Const PATCH_06 As Long = 116 'Address of the previous WndProc Const PATCH_07 As Long = 121 'Relative address of CallWindowProc Const PATCH_0A As Long = 186 'Address of the owner object Static aBuf(1 To CODE_LEN) As Byte 'Static code buffer byte array Static pCWP As Long 'Address of the CallWindowsProc Static pEbMode As Long 'Address of the EbMode IDE break/stop/running function Static pSWL As Long 'Address of the SetWindowsLong function Dim i As Long 'Loop index Dim j As Long 'Loop index Dim nSubIdx As Long 'Subclass data index Dim sHex As String 'Hex code string 'If it's the first time through here.. If aBuf(1) = 0 Then 'The hex pair machine code representation. sHex = "5589E583C4F85731C08945FC8945F8EB0EE80000000083F802742185C07424E830000000837DF800750AE838000000E84D00" & _ "00005F8B45FCC9C21000E826000000EBF168000000006AFCFF7508E800000000EBE031D24ABF00000000B900000000E82D00" & _ "0000C3FF7514FF7510FF750CFF75086800000000E8000000008945FCC331D2BF00000000B900000000E801000000C3E33209" & _ "C978078B450CF2AF75278D4514508D4510508D450C508D4508508D45FC508D45F85052B800000000508B00FF90A4070000C3" 'Convert the string from hex pairs to bytes and store in the static machine code buffer i = 1 Do While j < CODE_LEN j = j + 1 aBuf(j) = Val("&H" & Mid$(sHex, i, 2)) 'Convert a pair of hex characters to an eight-bit value and store in the static code buffer array i = i + 2 Loop 'Next pair of hex characters 'Get API function addresses If Subclass_InIDE Then 'If we're running in the VB IDE aBuf(16) = &H90 'Patch the code buffer to enable the IDE state code aBuf(17) = &H90 'Patch the code buffer to enable the IDE state code pEbMode = zAddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll If pEbMode = 0 Then 'Found? pEbMode = zAddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps End If End If pCWP = zAddrFunc(MOD_USER, FUNC_CWP) 'Get the address of the CallWindowsProc function pSWL = zAddrFunc(MOD_USER, FUNC_SWL) 'Get the address of the SetWindowLongA function ReDim sc_aSubData(0 To 0) As tSubData 'Create the first sc_aSubData element Else nSubIdx = zIdx(lng_hWnd, True) If nSubIdx = -1 Then 'If an sc_aSubData element isn't being re-cycled nSubIdx = UBound(sc_aSubData()) + 1 'Calculate the next element ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData 'Create a new sc_aSubData element End If Subclass_Start = nSubIdx End If With sc_aSubData(nSubIdx) .hWnd = lng_hWnd 'Store the hWnd .nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN) 'Allocate memory for the machine code WndProc .nAddrOrig = SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrSub) 'Set our WndProc in place Call RtlMoveMemory(ByVal .nAddrSub, aBuf(1), CODE_LEN) 'Copy the machine code from the static byte array to the code array in sc_aSubData Call zPatchRel(.nAddrSub, PATCH_01, pEbMode) 'Patch the relative address to the VBA EbMode api function, whether we need to not.. hardly worth testing Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig) 'Original WndProc address for CallWindowProc, call the original WndProc Call zPatchRel(.nAddrSub, PATCH_03, pSWL) 'Patch the relative address of the SetWindowLongA api function Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig) 'Original WndProc address for SetWindowLongA, unsubclass on IDE stop Call zPatchRel(.nAddrSub, PATCH_07, pCWP) 'Patch the relative address of the CallWindowProc api function Call zPatchVal(.nAddrSub, PATCH_0A, ObjPtr(Me)) 'Patch the address of this object instance into the static machine code buffer End With End Function 'Stop all subclassing Private Sub Subclass_StopAll() Dim i As Long i = UBound(sc_aSubData()) 'Get the upper bound of the subclass data array Do While i >= 0 'Iterate through each element With sc_aSubData(i) If .hWnd <> 0 Then 'If not previously Subclass_Stop'd Call Subclass_Stop(.hWnd) 'Subclass_Stop End If End With i = i - 1 'Next element Loop End Sub 'Stop subclassing the passed window handle Private Sub Subclass_Stop(ByVal lng_hWnd As Long) 'Parameters: 'lng_hWnd - The handle of the window to stop being subclassed With sc_aSubData(zIdx(lng_hWnd)) Call SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrOrig) 'Restore the original WndProc Call zPatchVal(.nAddrSub, PATCH_05, 0) 'Patch the Table B entry count to ensure no further 'before' callbacks Call zPatchVal(.nAddrSub, PATCH_09, 0) 'Patch the Table A entry count to ensure no further 'after' callbacks Call GlobalFree(.nAddrSub) 'Release the machine code memory .hWnd = 0 'Mark the sc_aSubData element as available for re-use .nMsgCntB = 0 'Clear the before table .nMsgCntA = 0 'Clear the after table Erase .aMsgTblB 'Erase the before table Erase .aMsgTblA 'Erase the after table End With End Sub '====================================================================================================== 'These z??? routines are exclusively called by the Subclass_??? routines. 'Worker sub for Subclass_AddMsg Private Sub zAddMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long) Dim nEntry As Long 'Message table entry index Dim nOff1 As Long 'Machine code buffer offset 1 Dim nOff2 As Long 'Machine code buffer offset 2 If uMsg = ALL_MESSAGES Then 'If all messages nMsgCnt = ALL_MESSAGES 'Indicates that all messages will callback Else 'Else a specific message number Do While nEntry < nMsgCnt 'For each existing entry. NB will skip if nMsgCnt = 0 nEntry = nEntry + 1 If aMsgTbl(nEntry) = 0 Then 'This msg table slot is a deleted entry aMsgTbl(nEntry) = uMsg 'Re-use this entry Exit Sub 'Bail ElseIf aMsgTbl(nEntry) = uMsg Then 'The msg is already in the table! Exit Sub 'Bail End If Loop 'Next entry nMsgCnt = nMsgCnt + 1 'New slot required, bump the table entry count ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long 'Bump the size of the table. aMsgTbl(nMsgCnt) = uMsg 'Store the message number in the table End If If When = eMsgWhen.MSG_BEFORE Then 'If before nOff1 = PATCH_04 'Offset to the Before table nOff2 = PATCH_05 'Offset to the Before table entry count Else 'Else after nOff1 = PATCH_08 'Offset to the After table nOff2 = PATCH_09 'Offset to the After table entry count End If If uMsg <> ALL_MESSAGES Then Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1))) 'Address of the msg table, has to be re-patched because Redim Preserve will move it in memory. End If Call zPatchVal(nAddr, nOff2, nMsgCnt) 'Patch the appropriate table entry count End Sub 'Return the memory address of the passed function in the passed dll Private Function zAddrFunc(ByVal sDLL As String, ByVal sProc As String) As Long zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc) Debug.Assert zAddrFunc 'You may wish to comment out this line if you're using vb5 else the EbMode GetProcAddress will stop here everytime because we look for vba6.dll first End Function 'Worker sub for Subclass_DelMsg Private Sub zDelMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long) Dim nEntry As Long If uMsg = ALL_MESSAGES Then 'If deleting all messages nMsgCnt = 0 'Message count is now zero If When = eMsgWhen.MSG_BEFORE Then 'If before nEntry = PATCH_05 'Patch the before table message count location Else 'Else after nEntry = PATCH_09 'Patch the after table message count location End If Call zPatchVal(nAddr, nEntry, 0) 'Patch the table message count to zero Else 'Else deleteting a specific message Do While nEntry < nMsgCnt 'For each table entry nEntry = nEntry + 1 If aMsgTbl(nEntry) = uMsg Then 'If this entry is the message we wish to delete aMsgTbl(nEntry) = 0 'Mark the table slot as available Exit Do 'Bail End If Loop 'Next entry End If End Sub 'Get the sc_aSubData() array index of the passed hWnd Private Function zIdx(ByVal lng_hWnd As Long, Optional ByVal bAdd As Boolean = False) As Long 'Get the upper bound of sc_aSubData() - If you get an error here, you're probably Subclass_AddMsg-ing before Subclass_Start zIdx = UBound(sc_aSubData) Do While zIdx >= 0 'Iterate through the existing sc_aSubData() elements With sc_aSubData(zIdx) If .hWnd = lng_hWnd Then 'If the hWnd of this element is the one we're looking for If Not bAdd Then 'If we're searching not adding Exit Function 'Found End If ElseIf .hWnd = 0 Then 'If this an element marked for reuse. If bAdd Then 'If we're adding Exit Function 'Re-use it End If End If End With zIdx = zIdx - 1 'Decrement the index Loop If Not bAdd Then Debug.Assert False 'hWnd not found, programmer error End If 'If we exit here, we're returning -1, no freed elements were found End Function 'Patch the machine code buffer at the indicated offset with the relative address to the target address. Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long) Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4) End Sub 'Patch the machine code buffer at the indicated offset with the passed value Private Sub zPatchVal(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nValue As Long) Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4) End Sub 'Worker function for Subclass_InIDE Private Function zSetTrue(ByRef bValue As Boolean) As Boolean zSetTrue = True bValue = True End Function Private Function LowWord(ByVal inDWord As Long) As Integer LowWord = inDWord And &H7FFF& If (inDWord And &H8000&) Then LowWord = LowWord Or &H8000 End Function Private Function HighWord(ByVal inDWord As Long) As Integer HighWord = LowWord(((inDWord And &HFFFF0000) \ &H10000) And &HFFFF&) End Function Private Function SWordToUWord(ByVal inWord As Integer) As Long SWordToUWord = CLng(inWord) And &HFFFF& End Function |