' Function designed to let you know if the mouse is currently within the bounds of
' the specified control on the specified form.
' NOTE - This function assumes that the specified control's parent is the specified
' form _OR_ the specified control is within another control who's parent
' is the specified form.
Private Function Mouse_InBounds(ByVal TheForm As Object, ByVal TheControl As Control) As Boolean
On Error Resume Next
Dim TitlebarHeight As Long
Dim ControlLeft As Long
Dim ControlTop As Long
Dim ControlHeight As Long
Dim ControlWidth As Long
' Get the height of the form's titlebar
TitlebarHeight = TheForm.Height - TheForm.ScaleHeight
' Get the left and top coordinates of the control
If TheControl.Parent = TheForm Then ' Control's parent is the form
ControlLeft = TheForm.Left + TheControl.Left
ControlTop = TheForm.Top + TheControl.Top + TitlebarHeight
Else ' The control's parent is another control
ControlLeft = TheForm.Left + TheControl.Parent.Left + TheControl.Left
ControlTop = TheForm.Top + TheControl.Parent.Top + TheControl.Top + TitlebarHeight
End If
ControlHeight = TheControl.Height
ControlWidth = TheControl.Width
' If the ScaleMode is TwipsPerPixel, adjust the measurements accordingly
If TheForm.ScaleMode = vbTwips Then
ControlLeft = ControlLeft / Screen.TwipsPerPixelX
ControlTop = ControlTop / Screen.TwipsPerPixelY
ControlWidth = TheControl.Width / Screen.TwipsPerPixelX
ControlHeight = TheControl.Height / Screen.TwipsPerPixelY
End If
' Check if the mouse is within the specified object / control
If Mouse_X > ControlLeft And _
Mouse_X < ControlLeft + ControlWidth And _
Mouse_Y > ControlTop And _
Mouse_Y < ControlTop + ControlHeight Then
Mouse_InBounds = True
Else
Mouse_InBounds = False
End If
End Function
' This is the subclassing function where vents are passed to
Public Function Mouse_MessageProc(ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
' Show the messages being passed to the process
If Mouse_ShowDebug = True Then
Debug.Print "hwnd=" & CStr(hWnd) & ", msg=" & CStr(MSG) & ", wParam=" & CStr(wParam) & ", lParam=" & CStr(lParam)
End If
' Process the messages
Select Case MSG
Case MSWHEEL_ROLLMSG ' Mouse wheel event
' Set the current mouse X and Y coordinates
Mouse_X = lParam And 65535
Mouse_Y = lParam \ 65535
' Return if the mouse wheel was rolled up or down
If wParam > 0 Then
Mouse_RollUp = True
Else
Mouse_RollUp = False
End If
' If the user specified a control and the form, then check if the
' mouse is within the bounds of that control. If it's not within
' the specified control's bounds, exit out of this routine.
If Not Mouse_Control Is Nothing And Not Mouse_Form Is Nothing Then
If Mouse_InBounds(Mouse_Form, Mouse_Control) = False Then
GoTo Finished
End If
End If
'******************************************************************************
' PUT YOUR CODE HERE TO PROCESS THE MOUSE WHEEL EVENT
' OR
' CALL A FUNCTION HERE THAT PROCESS THE MOUSE WHEEL EVENT
'******************************************************************************
' Allow the messages to continue to where they are supposed to go
Mouse_MessageProc = CallWindowProc(PreviousWndProc, hWnd, MSG, wParam, lParam)
End Function
' Function to set the windows information variables
Private Function GetOS() As Boolean
On Error GoTo TheEnd
Dim OSinfo As OSVERSIONINFO
Dim RetValue As Long
Dim PID As String
OSinfo.dwOSVersionInfoSize = 148
OSinfo.szCSDVersion = Space(128)
RetValue = GetVersionEx(OSinfo)
If RetValue = 0 Then
Win_Build = ""
Win_OS = OS_Unknown
Win_Version = ""
GetOS = False
Exit Function
End If
With OSinfo
Select Case .dwPlatformId
Case VER_PLATFORM_WIN32s
PID = "Win 32"
Win_OS = OS_Win32
Case VER_PLATFORM_WIN32_WINDOWS
If .dwMinorVersion = 0 Then
PID = "Windows 95"
Win_OS = OS_Win95
ElseIf .dwMinorVersion = 10 Then
PID = "Windows 98"
Win_OS = OS_Win98
End If
Case VER_PLATFORM_WIN32_NT
If .dwMajorVersion = 3 Then
PID = "Windows NT 3.51"
Win_OS = OS_WinNT_351
ElseIf .dwMajorVersion = 4 Then
PID = "Windows NT 4.0"
Win_OS = OS_WinNT_40
ElseIf .dwMajorVersion = 5 Then
PID = "Windows 2000"
Win_OS = OS_Win2000
End If
Case Else
PID = "Unknown"
Win_OS = OS_Unknown
End Select
End With
' Function that subclasses the specified form to trap mouse events
Public Function Mouse_HookForm(ByVal FormHandle As Long)
On Error Resume Next
' Check if there's a wheel mouse present
' (NOTE - This only checks if a mouse is present once)
If CheckedWheel = True And WheelExists = False Then
Exit Function
ElseIf CheckedWheel = True And WheelExists = True Then
DoEvents
ElseIf CheckedWheel = False Then
If Mouse_CheckForWheel = True Then
CheckedWheel = True
WheelExists = True
Else
CheckedWheel = True
WheelExists = False
Exit Function
End If
End If
' If there was a previously sublcassed form, release it so as to avoid problems
If PreviousHWND <> 0 Then
Mouse_UnhookForm PreviousHWND
DoEvents
End If
' Check the operating system
' (NOTE - This only checks the OS once, and if it fails doesn't try again)
If Win_OS = OS_Unknown And CantGetOSInfo = False Then
If GetOS = False Then
CantGetOSInfo = True
End If
End If
' Set the windows message to look for in the sublcass event
If Win_OS = OS_Win98 Or Win_OS = OS_WinNT_40 Or Win_OS = OS_Win2000 Then
MSWHEEL_ROLLMSG = &H20A
Else
MSWHEEL_ROLLMSG = RegisterWindowMessage("MSWHEEL_ROLLMSG")
End If
' Set "Mouse_MessageProc" as the new message handling function... and at
' the same time, record what the previous message handler was.
PreviousWndProc = SetWindowLong(FormHandle, GWL_WNDPROC, AddressOf Mouse_MessageProc)
' Set the last form hooked for unhook later
PreviousHWND = FormHandle
End Function
' Function that releases the specified form from the subclass
Public Function Mouse_UnhookForm(ByVal FormHandle As Long)
On Error Resume Next
If FormHandle <> 0 Then
SetWindowLong FormHandle, GWL_WNDPROC, PreviousWndProc
End If
End Function
' Function that checks for a wheel mouse
Public Function Mouse_CheckForWheel() As Boolean
On Error Resume Next
' Check for wheel mouse on Win98, WinNT 4.0, & Win2000
If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
Mouse_CheckForWheel = True
' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
ElseIf FindWindow("MouseZ", "Magellan MSWHEEL") <> 0 Then
Mouse_CheckForWheel = True
' Wheel mouse not found
Else
Mouse_CheckForWheel = False
End If
'================================================================================
'
' modWheelMouse Module
' --------------------
'
' Created By : Kevin Wilson
' http://www.TheVBZone.com ( The VB Zone )
'
' Last Update : June 06, 2000
'
' VB Versions : 5.0 / 6.0
'
' Requires : A Microsoft Intellimouse (or compatible wheel mouse)
'
' Description : This module was created to make it possible to easily trap
' mouse wheel events that are sent to the specified form.
'
' Note : This module can be used for multiple forms if:
' 1) The Mouse_Form and Mouse_Control variables are set
' and the Mouse_HookForm function is called from within
' the Form_Activate() event. The Form_Activate event is
' fired when the focus is passed back and forth between
' different forms within the same project.
' 2) The process done in the Mouse_MessageProc is a PUBLIC
' process that is not specific to any one form.
'
' WARNING : Failure to unhook a window before its imminent destruction may
' result in application errors, Invalid Page Faults, and data
' loss. This is due the fact that the new WindowProc function
' being pointed to no longer exists, but the window has not been
' notified of the change. Always unhook the sub-classed window
' upon unloading the sub-classed form or exiting the application.
' This is especially important while debugging an application
' that uses this technique within the Microsoft Visual Basic
' Development Environment (IDE). Pressing the END button or
' selecting END from the Run menu without unhooking may cause an
' Invalid Page Fault and close Microsoft Visual Basic. Changes
' to the active project will be lost.
'
' See Also : http://support.microsoft.com/support/kb/articles/Q231/4/65.ASP
' http://www.microsoft.com/products/hardware/mouse/intellimouse/sdk/sdkmessaging.htm
'
' Example Use :
'
' Private Sub Form_Load()
' Set Mouse_Form = Me
' Set Mouse_Control = Picture1
' Mouse_ShowDebug = False
' Mouse_HookForm Me.hwnd
' End Sub
'
' Private Sub Form_Unload(Cancel As Integer)
' Mouse_UnhookForm Me.hwnd
' End Sub
' Declare Types / Enumerations
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
' Variables to hold the Operating System's information
Private Win_OS As OSTypes
Private Win_Version As String
Private Win_Build As String
Private CantGetOSInfo As Boolean
' Variables to hold hook information
Private CheckedWheel As Boolean
Private WheelExists As Boolean
Private PreviousWndProc As Long
Private PreviousHWND As Long
' Variables that return information about the mouse
Public Mouse_X As Integer
Public Mouse_Y As Integer
Public Mouse_RollUp As Boolean
Public Mouse_ShowDebug As Boolean
Public Mouse_Control As Control
Public Mouse_Form As Form
' Windows API Declarations
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 Function RegisterWindowMessage Lib "USER32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long
WM_MOUSEWHEEL
The WM_MOUSEWHEEL message is sent to the focus window when the mouse wheel is rotated. The DefWindowProc function propagates the message to the window's parent. There should be no internal forwarding of the message, since DefWindowProc propagates it up the parent chain until it finds a window that processes it.
WM_MOUSEWHEEL
fwKeys = LOWORD(wParam); // key flags
zDelta = (short) HIWORD(wParam); // wheel rotation
xPos = (short) LOWORD(lParam); // horizontal position of pointer
yPos = (short) HIWORD(lParam); // vertical position of pointer
Parameters
fwKeys
Value of the low-order word of wParam. Indicates whether various virtual keys are down. This parameter can be any combination of the following values: Value Description
MK_CONTROL Set if the ctrl key is down.
MK_LBUTTON Set if the left mouse button is down.
MK_MBUTTON Set if the middle mouse button is down.
MK_RBUTTON Set if the right mouse button is down.
MK_SHIFT Set if the shift key is down.
zDelta
The value of the high-order word of wParam. Indicates the distance that the wheel is rotated, expressed in multiples or divisions of WHEEL_DELTA, which is 120. A positive value indicates that the wheel was rotated forward, away from the user; a negative value indicates that the wheel was rotated backward, toward the user.
xPos
Value of the low-order word of lParam. Specifies the x-coordinate of the pointer, relative to the upper-left corner of the screen.
yPos
Value of the high-order word of lParam. Specifies the y-coordinate of the pointer, relative to the upper-left corner of the screen.
Remarks
The zDelta parameter will be a multiple of WHEEL_DELTA, which is set at 120. This is the threshold for action to be taken, and one such action (for example, scrolling one increment) should occur for each delta.
The delta was set to 120 to allow Microsoft or other vendors to build finer-resolution wheels in the future, including perhaps a freely-rotating wheel with no notches. The expectation is that such a device would send more messages per rotation, but with a smaller value in each message. To support this possibility, you should either add the incoming delta values until WHEEL_DELTA is reached (so for a given delta-rotation you get the same response), or scroll partial lines in response to the more frequent messages. You could also choose your scroll granularity and accumulate deltas until it is reached.
QuickInfo
Windows NT: Requires version 4.0 or later.
Windows: Requires Windows 98.
Windows CE: Unsupported.
Header: Declared in winuser.h.
See Also
Mouse Input Overview, Mouse Input Messages,GetSystemMetrics, mouse_event,SystemParametersInfo