Question

vb鼠标滚轮问题

求一个和鼠标滚轮控制有关的例子

Answer 1

首先你的要求无法满足，因为你的是类模块，类模块内的任何过程都是对外不可见的，监视全局鼠标事件必须要提供一个全局可见的（可以使用AddressOf符号的）过程，这个过程必须在模块里用public方式声明，在类模块里做不到。

其次，你希望触发一个事件，然后让你执行代码，但是windows系统有要求就是鼠标事件钩子不可以被其它代码中断，也就是说就算你拿到了这个事件也不可以做进一步处理，否则别的程序无法正常接受消息，严重的时候会让系统崩溃。

唯一的手段是放到模块里，将鼠标事件写入一个标志变量里，然后用timer去读这个变量是可以的，以下是代码：

窗口内添加一个按钮和一个timer控件
代码如下

Private Sub Command1_Click()
If hookId = 0 Then
hookId = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, App.hInstance, 0)
ElseIf hookId <> 0 Then
UnhookWindowsHookEx hookId
hookId = 0
End If
End Sub

Private Sub Form_Load()
Timer1.Interval = 10
End Sub

Private Sub Form_Unload(Cancel As Integer)
If hookId <> 0 Then
UnhookWindowsHookEx hookId
hookId = 0
End If
End Sub

Private Sub Timer1_Timer()
If EventRaised = True Then
Debug.Print Direction
EventRaised = False
End If
End Sub

添加一个模块，粘贴如下代码：
Option Explicit
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Const WH_MOUSE_LL = 14
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Const WM_MOUSEWHEEL = &H20A
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As MSLLHOOKSTRUCT, ByVal Source As Long, ByVal Length As Long)

Public hookId As Long
Public Direction As Boolean
Public EventRaised As Boolean
Public Type MSLLHOOKSTRUCT
ptx As Long
pty As Long
deltax As Long
deltay As Long
time As Long
extinfo As Long
End Type

Public Function MouseProc(ByVal ncode As Long, ByVal wp As Long, ByVal lp As Long) As Long
Dim ll As MSLLHOOKSTRUCT
If wp = WM_MOUSEWHEEL Then
CopyMemory ll, lp, Len(ll)
If ll.deltax < 0 Then
Direction = False
Else
Direction = True
End If
EventRaised = True
End If
MouseProc = CallNextHookEx(hookId, ncode, wp, lp)
End Function

'运行的时候滚动滚轮可以看到调试窗口有信息输出，不明白的请百度HI我

'运行这个程序的时候务必正常关闭窗口，而不是直接在VB里中断掉，否则会让VB挂掉，因为你的钩子不正常退出会让程序崩溃

Answer 2

模块中：
'支持滚轮鼠标API---------------------------------
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MOUSEWHEEL = &H20A

Public Oldwinproc As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Public Function FlexScroll(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'支持滚轮的滚动
Select Case wMsg
Case WM_MOUSEWHEEL
Select Case wParam
Case -7864320 '向下滚
SendKeys "{DOWN}"
SendKeys "{DOWN}"
SendKeys "{DOWN}"

Case 7864320 '向上滚
SendKeys "{UP}"
SendKeys "{UP}"
SendKeys "{UP}"

End Select

End Select
FlexScroll = CallWindowProc(Oldwinproc, hWnd, wMsg, wParam, lParam)
End Function
'支持滚轮鼠标API---------------------------------
窗体里：
Private Sub Form_Load()
MSFlexGrid1.Rows = 100
MSFlexGrid1.Cols = 100
End Sub

Private Sub MSFlexGrid1_GotFocus()
Oldwinproc = GetWindowLong(Me.hWnd, GWL_WNDPROC)
SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf FlexScroll
End Sub

Private Sub MSFlexGrid1_LostFocus()
SetWindowLong Me.hWnd, GWL_WNDPROC, Oldwinproc
End Sub

Answer 3

麻烦