处理WM_MOUSEWHEEL消息！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. Res 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
让VB应用程序支持鼠标滚轮 ---- 一、提出问题 ---- 自从1996年微软推出Intellimouse鼠标后，带滚轮的鼠标开始大行其道，支持鼠标 滚轮的应用软件也越来越多。但我感到奇怪，为什么VB到6.0本身仍然不支持鼠标滚轮， VF可是从5.0就提供MouseWheel事件了。 ---- 如何让VB应用程序支持鼠标滚轮？MSDN上有一篇解决VB下应用Intellimouse鼠标的 文章，它解决这一问题的方法是通过一个几十K的第三方控件实现的，可惜该控件没有源 代码。况且为了支持鼠标滚轮使用一个第三方控件，好像有点得不偿失。本文给出用纯 VB实现这一功能的方法。 ---- 二、解决问题 ---- 我们知道VB应用程序响应的Windows传来的消息，需要通过VB解释。可是很不幸， 虽然VB解释所有得消息，却只让用户程序在事件中处理部分消息，VB自己处理其他的消 息，或者忽略这些消息。 ---- 在VB5.0以前应用程序无法越过VB直接处理消息，微软从VB5.0开始提供AddressOf 运算符，该运算符可以让用户程序将函数或者过程的地址传递给一个API函数。这样我 们就可以在VB应用程序中编写自己的窗口处理函数，通过AddressOf 运算符将在VB中定 义的窗口地址传递给窗口处理函数，从而绕过VB的解释器，自己处理消息。事实上，该 方法可用于在VB中处理任何消息。 ---- 实现应用程序支持鼠标滚轮的关键是，捕获鼠标滚轮的消息 MSH_MOUSEWHEEL、WM _MOUSEWHEEL。其中MSH_MOUSEWHEEL是为95准备的，需要Intellimouse驱动程序，而WM_ MOUSEWHEEL是目前各版本Windows（98/NT40/2000）内置的消息。本文主要处理WM_MOUS EWHEEL消息。下面是WM_MOUSEWHEEL的语法。 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 */ ---- 其中：fwKeys指出是否有CTRL、SHIFT、鼠标键(左、中、右、附加)按下，允许复 合。zDelta传递滚轮滚动的快慢，该值小于零表示滚轮向后滚动（朝用户方向），大于 零表示滚轮向前滚动（朝显示器方向）。lParam指出鼠标指针相对屏幕左上的x、y轴坐 标。 ---- 滚轮按钮相当于普通的三键鼠标的中键，根据滚轮按钮的动作，Windows分别发出 WM_MBUTTONUP、WM_MBUTTONDOWN、WM_MBUTTONDBLCLK消息，这些消息VB已经在鼠标事件 中支持。 ---- 三、实际应用 ---- 根据上述原理，给出一个数据库应用的典型例子。 ---- 1.用户界面班级和学生一对多的查询，当用户在学生网格以外滚动鼠标滚轮，班级 主表前后移动；用户在网格以内滚动鼠标学生明细表垂直移动；如果在网格以内按住鼠 标滚轮键并且滚动鼠标，学生明细表水平移动。 ---- 2.Form1上ADO Data 控件对象datPrimaryRS的 ConnectionString为"PROVIDER=MS DataShape;Data PROVIDER=MSDASQL;dsn=SCHOOL;uid=;pwd=;"， RecordSelectors 属性 的SQL命令文本为"SHAPE {select * from 班级} AS ParentCMD APPEND ({select * fr om 学生 } AS ChildCMD RELATE 班级名称 TO 班级名称) AS ChildCMD"。 ---- 3.TextBox的DataSource均为datPrimaryRS,DataFiled如图所示。 ---- 4.窗口下部的网格是DataGrid控件,名称为grdDataGrid。 ---- 5.表单From1.frm的清单如下： Private Sub Form_Load() Set grdDataGrid.DataSource = _ datPrimaryRS.Recordset("ChildCMD").UnderlyingValue Hook Me.hWnd End Sub Private Sub Form_Unload(Cancel As Integer) UnHook Me.hWnd End Sub ---- 6.标准模块Module1.bas清单如下： Option Explicit Public Type POINTL x As Long y As Long End Type 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 Declare Function SystemParametersInfo _ Lib "USER32" Alias "SystemParametersInfoA" _ (ByVal uAction As Long, _ ByVal uParam As Long, _ lpvParam As Any, _ ByVal fuWinIni As Long) As Long Declare Function ScreenToClient Lib "USER32" _ (ByVal hWnd As Long, xyPoint As POINTL) As Long Public Const GWL_WNDPROC = -4 Public Const SPI_GETWHEELSCROLLLINES = 104 Public Const WM_MOUSEWHEEL = &H20A Public WHEEL_SCROLL_LINES As Long Global lpPrevWndProc As Long Public Sub Hook(ByVal hWnd As Long) lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, _ AddressOf WindowProc) '获取"控制面板"中的滚动行数值 Call SystemParametersInfo(SPI_GETWHEELSCROLLLINES, _ 0, WHEEL_SCROLL_LINES, 0) If WHEEL_SCROLL_LINES > Form1.grdDataGrid.VisibleRows Then WHEEL_SCROLL_LINES = Form1.grdDataGrid.VisibleRows End If End Sub Public Sub UnHook(ByVal hWnd As Long) Dim lngReturnValue As Long lngReturnValue = SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc) End Sub Function WindowProc(ByVal hw As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim pt As POINTL Select Case uMsg Case WM_MOUSEWHEEL Dim wzDelta, wKeys As Integer wzDelta = HIWORD(wParam) wKeys = LOWORD(wParam) pt.x = LOWORD(lParam) pt.y = HIWORD(lParam) '将屏幕坐标转换为Form1.窗口坐标 ScreenToClient Form1.hWnd, pt With Form1.grdDataGrid '判断坐标是否在Form1.grdDataGrid窗口内 If pt.x > .Left / Screen.TwipsPerPixelX And _ pt.x < (.Left + .Width) / Screen.TwipsPerPixelX And _ pt.y > .Top / Screen.TwipsPerPixelY And _ pt.y < (.Top + .Height) / Screen.TwipsPerPixelY Then '滚动明细数据库 If wKeys = 16 Then '滚动键按下，水平滚动grdDataGrid If Sgn(wzDelta) = 1 Then Form1.grdDataGrid.Scroll -1, 0 Else Form1.grdDataGrid.Scroll 1, 0 End If Else '垂直滚动grdDataGrid If Sgn(wzDelta) = 1 Then Form1.grdDataGrid.Scroll 0, 0 - WHEEL_SCROLL_LINES Else Form1.grdDataGrid.Scroll 0, WHEEL_SCROLL_LINES End If End If Else '鼠标不在grdDataGrid区域，滚动主数据库 With Form1.datPrimaryRS.Recordset If Sgn(wzDelta) = 1 Then If .BOF = False Then .MovePrevious If .BOF = True Then .MoveFirst End If End If Else If .EOF = False Then .MoveNext If .EOF = True Then .MoveLast End If End If End If End With End If End With Case Else WindowProc = CallWindowProc(lpPrevWndProc, hw, _ uMsg, wParam, lParam) End Select End Function Public Function HIWORD(LongIn As Long) As Integer ' 取出32位值的高16位 HIWORD = (LongIn And &HFFFF0000) \ &H10000 End Function Public Function LOWORD(LongIn As Long) As Integer ' 取出32位值的低16位 LOWORD = LongIn And &HFFFF& End Function ---- 7.该例在未安装任何附加鼠标驱动程序的Win2000/98环境，采用联想网络鼠标/罗 技银貂，VB6.0下均通过。 ---- 需要进一步说明的是,对用户界面鼠标滚轮的操作也要遵循公共用户界面操作习惯 ，不要随意定义一些怪异的操作，如果你编制的应用程序支持鼠标滚轮，请看看是否符 合下面这些标准。 ---- 垂直滚动：当用户向后滚动轮子（朝用户方向），滚动条向下移动；向前滚动轮子 （朝显示器方向），滚动条向上移动。对文档当前的选择应
Option Explicit '================================================================================ ' ' 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 TypePrivate Enum OSTypes OS_Unknown = 0 ' "Unknown" OS_Win32 = 32 ' "Win 32" OS_Win95 = 95 ' "Windows 95" OS_Win98 = 98 ' "Windows 98" OS_WinNT_351 = 351 ' "Windows NT 3.51" OS_WinNT_40 = 40 ' "Windows NT 4.0" OS_Win2000 = 2000 ' "Windows 2000" End Enum' Constants Private Const VER_PLATFORM_WIN32s = 0 Private Const VER_PLATFORM_WIN32_WINDOWS = 1 Private Const VER_PLATFORM_WIN32_NT = 2 Private Const GWL_WNDPROC = (-4) Private Const SM_MOUSEWHEELPRESENT = 75 Private MSWHEEL_ROLLMSG As Long ' Variable constant value' 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
' 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
End Function
' 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
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.
Res
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
'================================================================================
'
' 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 TypePrivate Enum OSTypes
OS_Unknown = 0 ' "Unknown"
OS_Win32 = 32 ' "Win 32"
OS_Win95 = 95 ' "Windows 95"
OS_Win98 = 98 ' "Windows 98"
OS_WinNT_351 = 351 ' "Windows NT 3.51"
OS_WinNT_40 = 40 ' "Windows NT 4.0"
OS_Win2000 = 2000 ' "Windows 2000"
End Enum' Constants
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const GWL_WNDPROC = (-4)
Private Const SM_MOUSEWHEELPRESENT = 75
Private MSWHEEL_ROLLMSG As Long ' Variable constant value' 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
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
End Function
' 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
'******************************************************************************
Debug.Print " ********** FIRE EVENT ! **********"
'******************************************************************************
End Select
Finished:
' 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
Win_Version = Trim(Str(OSinfo.dwMajorVersion) & "." & LTrim(Str(OSinfo.dwMinorVersion)))
Win_Build = Trim(Str(OSinfo.dwBuildNumber))
GetOS = True
Exit Function
TheEnd:
Err.Clear
GetOS = False
End Function
我用你的方法已经解决了我的问题。
别人的方法我虽然没试，但我想一定也错不了，谢谢大家!