Re: reading mouse wheel rotation in VB6

Tech-Archive recommends: Fix windows errors by optimizing your registry

"JanAdam" <JanAdam@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message
news:4F1CDAC9-BA1C-44AF-9C1A-DCE53E15368B@xxxxxxxxxxxxxxxx
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.


.

Quantcast