vb鼠标滚轮问题

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

答案：标滚轮能给系统的使用带来很大便利，如使用滚轮移动选择这项，但在VB中的一些常用控件（如：文件框、列表框等）中没有提供鼠标滚轮滚动选择的效果。现将自己写的鼠标滚轮特效实现代码分享给大家： 
　　本例子就是一个对Win32 API的调用，达到对ListBox、PictureBox等的鼠标滚轮控制。首先，申明windows API调用，将其放在模块modWheel中，以供用户控件使用。原理很简单，通过鼠标滚轮可以对如下白色的横线进行控制，效果图如下：
　　相关代码如下：
 鼠标滚轮处理模块(modWheel) 
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
     (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
     (ByVal hWnd As Long, ByVal nIndex 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
Public Const GWL_WNDPROC = (-4)
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 SetProp Lib "user32" Alias "SetPropA" _
     (ByVal hWnd As Long, ByVal lpString As String, _
     ByVal hData As Long) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" _
     (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
     (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Public Const WM_MOUSEWHEEL = &H20A
Public Const WM_MOUSELAST = &H20A
Public Const WHEEL_DELTA = 120
Public Function HIWORD(LongIn As Long) As Integer
   HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function
Public Function MWheelProc(ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
     Dim OldProc As Long
     Dim CtlWnd As Long
     Dim CtlPtr As Long
     Dim IntObj As Object
     Dim MWObject As MWheel
     CtlWnd = GetProp(hWnd, "WheelWnd")
     CtlPtr = GetProp(CtlWnd, "WheelPtr")
     OldProc = GetProp(CtlWnd, "OldWheelProc")
     If wMsg = WM_MOUSEWHEEL Then
          CopyMemory IntObj, CtlPtr, 4
          Set MWObject = IntObj
          MWObject.WndProc hWnd, wMsg, wParam, lParam
          Set MWObject = Nothing
          CopyMemory IntObj, 0&, 4
          Exit Function
    End If
 MWheelProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
End Function
Public Sub Subclass(MWCtl As MWheel, ParentWnd As Long)
     If GetProp(MWCtl.hWnd, "OldWheelProc") <> 0 Then
          Exit Sub
     End If
     SetProp MWCtl.hWnd, "OldWheelProc", _
          GetWindowLong(ParentWnd, GWL_WNDPROC)
     SetProp MWCtl.hWnd, "WheelPtr", ObjPtr(MWCtl)
     SetProp ParentWnd, "WheelWnd", MWCtl.hWnd
     SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc
End Sub
Public Sub UnSubclass(MWCtl As MWheel, ParentWnd As Long)
     Dim OldProc As Long
     OldProc = GetProp(MWCtl.hWnd, "OldWheelProc")
     If OldProc = 0 Then Exit Sub
     SetWindowLong ParentWnd, GWL_WNDPROC, OldProc
     RemoveProp ParentWnd, "WheelWnd"
     RemoveProp MWCtl.hWnd, "WheelPtr"
     RemoveProp MWCtl.hWnd, "OldWheelProc"
End Sub
然后，定义用户控件MWheel，实现对相关控件鼠标滚轮事件的处理。
用户控件（MWheel)代码 
Option Explicit
Dim m_CapWnd As Long
Dim m_Subclassed As Boolean
Event WheelScroll(Shift As Integer, zDelta As Integer, _
    X As Single, Y As Single)
Private Sub UserControl_Resize()
     Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY
End Sub
Public Sub DisableWheel()
     If m_CapWnd = 0 Then Exit Sub
     If m_Subclassed = False Then Exit Sub
     UnSubclass Me, m_CapWnd
     m_Subclassed = False
End Sub
Public Sub EnableWheel()
     If m_CapWnd = 0 Then Exit Sub
     m_Subclassed = True
     Subclass Me, m_CapWnd
End Sub
Friend Property Get hWnd() As Long
     hWnd = UserControl.hWnd
End Property
Public Property Get hWndCapture() As Long
     hWndCapture = m_CapWnd
End Property
Public Property Let hWndCapture(ByVal vNewValue As Long)
     m_CapWnd = vNewValue
End Property
Friend Sub WndProc(ByVal hWnd As Lo

上一个：VB代码 转换C#代码
下一个：vb编程有点错误