自定义控件增加 MouseWheel 事件 (看官端着茶来吼~)

[ZOUYONG0929]

'自定义控件增加 MouseWheel 事件
'望看官指点
'注意~ 出错容易自行关闭整个VB,至此似乎****(略N字节),但愿是个案.[后果自负]
'危机意识-保存自己的成果
'-----------------
'运行VB6
'ActiveX控件-UserControl1
'添加->模块-Moduel1
'文件->添加工程->标准EXE-Form1
'-----------------------------
'Moduel1:
'-----------------------------

Option Explicit
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 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 Const WM_MOUSEWHEEL = &H20A

Public OldWindowProc As Long '用来保存系统默认的窗口消息处理函数的地址
Public Listener As UserControl1 '注意用户控件类型,

Public Function RegeditListenerMouseWheelEvent(ListenerObject As UserControl1) '注册用户控件 !注意类型
Set Listener = ListenerObject
OldWindowProc = GetWindowLong(ListenerObject.hWnd, GWL_WNDPROC)
Call SetWindowLong(ListenerObject.hWnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Function

'自定义的消息处理函数
'获得焦点的 接受消息
Public Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
If Msg = WM_MOUSEWHEEL Then

If wParam = -7864320 Then '向下滚动

Listener.MouseWheel 1

ElseIf wParam = 7864320 Then '向上滚动

Listener.MouseWheel 0

End If

Else
'调用默认窗口消息处理函数
NewWindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)
End If
End Function
'----------------------------------------
'UserControl1:
'----------------------------------------
Option Explicit

Public Event MouseWheel(Dnum As Integer)

Public Sub MouseWheel(Num As Integer)
RaiseEvent MouseWheel(Num)
End Sub

Public Property Get hWnd() As Long
hWnd = UserControl.hWnd
End Property

'该控件获取焦点时开始截取消息

Private Sub UserControl_GotFocus()
RegeditListenerMouseWheelEvent Me
End Sub
'---------------------------------------
'测试
'Form1:
'---------------------------------------
'添加用户控件UserControl1 ! 命名"ZY" ^-^
Option Explicit

Private Sub ZY_MouseWheel(Dnum As Integer)
Select Case Dnum
Case 0
MsgBox "MouseWheel_0"
Case 1
MsgBox "MouseWheel_1"
End Select
End Sub

[嗷嗷叫的老马]

If wParam = -7864320 Then '向下滚动

Listener.MouseWheel 1

ElseIf wParam = 7864320 Then '向上滚动

Listener.MouseWheel 0

End If

//

................这个.........