vb鼠标编程的实现

本例代码中包含vb鼠标的整体解决，不仅仅是解决滚轮问题！

vb滚轮的实现，不管是钩子还是子分类方式都极不稳定，

容易导致应用程序中止退出。

还是老外厉害，同样是api方式实现，

但本例的实现近乎完美，极其稳定！

缺陷大概是需要写多处的代码，滚动前需要单击滚轮

首先把模块MHookXP.bas，类CHookMouseWheel.cls，类CHookMouseEvents.cls加入你的工程中（在文档中后段）。

然后在需要滚轮的窗口中：

窗口模块声明：

Private WithEvents m_MW As CHookMouseWheel

窗口load事件添加代码

Private Sub Form_Load()

Set m_MW = New CHookMouseWheel

m_MW.hWnd = Me.hWnd

end sub

窗口中再添加如下代码，实现msflexgrid的滚轮查看数据。

Private Sub m_MW_MouseWheel(ByVal hWnd As Long, ByVal Delta As Long, ByVal Shift As Long, ByVal Button As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)

If TypeOf Screen.ActiveControl Is MSFlexGrid Then sub_MouseWheel Delta, X, Y End Sub

'下面这个过程可以放到公用模块中

Public Sub sub_MouseWheel(ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)

Dim NewValue As Long

Dim Lstep As Single '控制每次移动几行

Dim iA

On Error Resume Next

iA = 0

With Screen.ActiveControl

Lstep = .Height / .RowHeight(0)

Lstep = Int(Lstep)

If Lstep < 10 Then

Lstep = 10

End If

Lstep = 1

If Rotation > 0 Then

NewValue = .TopRow - Lstep

If NewValue < 1 Then

NewValue = 1

End If

Else

NewValue = .TopRow + Lstep

If NewValue > .Rows - 1 Then

NewValue = .Rows - 1

End If

End If

If .Rows > .FixedRows Then

iA = IIf(.FixedRows >= NewValue, .FixedRows, NewValue)

If iA > .Rows Then iA = .Rows - 1

.TopRow = iA

End If

End With

End Sub

下边是类CHookMouseWheel.cls的内容

' ************************************************************************* ' Copyright ?997-2009 Karl E. Peterson

' All Rights Reserved, http://www.77cn.com.cn/

' ************************************************************************* ' You are free to use this code within your own applications, but you

' are expressly forbidden from selling or otherwise distributing this

' source code, non-compiled, without prior written consent.

' ************************************************************************* Option Explicit

' Win32 API Declarations

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)

Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

' Mousewheel constants and data structures

Private Const WM_NCDESTROY As Long = &H82

Private Const WM_XBUTTONDOWN As Long = &H20B '(_WIN32_WINNT >= 0x0500)

Private Const WM_XBUTTONUP As Long = &H20C '(_WIN32_WINNT >= 0x0500)

Private Const WM_XBUTTONDBLCLK As Long = &H20D '(_WIN32_WINNT >= 0x0500)

Private Const WM_MOUSEWHEEL As Long = &H20A

Private Const WM_MOUSEHWHEEL As Long = &H20E '(_WIN32_WINNT >= 0x0600)

Private Const SM_MOUSEWHEELPRESENT As Long = 75

Private Const SPI_GETWHEELSCROLLLINES As Long = 104

Private Const SPI_SETWHEELSCROLLLINES As Long = 105

Private Const SPI_GETWHEELSCROLLCHARS As Long = 108 '(_WIN32_WINNT >= 0x0600)

Private Const SPI_SETWHEELSCROLLCHARS As Long = 109 '(_WIN32_WINNT >= 0x0600)

Private Const WHEEL_PAGESCROLL As Long = -1 ' (UINT_MAX) /* Scroll one page */

Private Const WHEEL_DELTA As Long = 120 ' /* Value for rolling one detent */

Private Type POINTAPI

X As Long

Y As Long

End Type

' Key State Masks for Mouse Messages

Private Const MK_LBUTTON As Long = &H1

Private Const MK_RBUTTON As Long = &H2

Private Const MK_SHIFT As Long = &H4

Private Const MK_CONTROL As Long = &H8

Private Const MK_MBUTTON As Long = &H10

' Key State Masks for GetKeyState function

Private Const VK_LBUTTON As Long = &H1

Private Const VK_RBUTTON As Long = &H2

Private Const VK_MBUTTON As Long = &H4 ' NOT contiguous with L RBUTTON

Private Const VK_SHIFT As Long = &H10

Private Const VK_CONTROL As Long = &H11

Private Const VK_MENU As Long = &H12

' Subclassing interface

Implements IHookXP

' Events

Public Event MouseWheel(ByVal hWnd As Long, ByVal Delta As Long, ByVal Shift As Long, ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByRef Cancel As Boolean)

Public Event MouseWheelH(ByVal hWnd As Long, ByVal Delta As Long, ByVal Shift As Long, ByVal Button As Long, ByVal X As Long, ByVal Y As Long, ByRef Cancel As Boolean)

' Member variables

Private m_hWnd As Long

Private m_Enabled As Boolean

' Default values.

Private Const defEnabled As Boolean = True

' *********************************************

' Initialize/Terminate

' *********************************************

Private Sub Class_Initialize()

' Set defaults

m_Enabled = defEnabled< …… 此处隐藏：18394字，全部文档内容请下载后查看。喜欢就下载吧 ……