标滚轮能给系统的使用带来很大便利,如使用滚轮移动选择这项,但在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 LongDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As LongPublic 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 LongDeclare Function SetProp Lib "user32" Alias "SetPropA" _ (ByVal hWnd As Long, ByVal lpString As String, _ ByVal hData As Long) As LongDeclare Function GetProp Lib "user32" Alias "GetPropA" _ (ByVal hWnd As Long, ByVal lpString As String) As LongDeclare Function RemoveProp Lib "user32" Alias "RemovePropA" _ (ByVal hWnd As Long, ByVal lpString As String) As LongDeclare Function GetParent Lib "user32" (ByVal hWnd As Long) As LongPublic Const WM_MOUSEWHEEL = &H20APublic Const WM_MOUSELAST = &H20APublic Const WHEEL_DELTA = 120Public Function HIWORD(LongIn As Long) As Integer HIWORD = (LongIn And &HFFFF0000) &H10000End FunctionPublic 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 FunctionPublic 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 MWheelProcEnd SubPublic 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 ExplicitDim m_CapWnd As LongDim m_Subclassed As BooleanEvent WheelScroll(Shift As Integer, zDelta As Integer, _ X As Single, Y As Single)Private Sub UserControl_Resize() Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelYEnd SubPublic Sub DisableWheel() If m_CapWnd = 0 Then Exit Sub If m_Subclassed = False Then Exit Sub UnSubclass Me, m_CapWnd m_Subclassed = FalseEnd SubPublic Sub EnableWheel() If m_CapWnd = 0 Then Exit Sub m_Subclassed = True Subclass Me, m_CapWndEnd SubFriend Property Get hWnd() As Long hWnd = UserControl.hWndEnd PropertyPublic Property Get hWndCapture() As Long hWndCapture = m_CapWndEnd PropertyPublic Property Let hWndCapture(ByVal vNewValue As Long) m_CapWnd = vNewValueEnd PropertyFriend Sub WndProc(ByVal hWnd As Long, _ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) Dim wShift As Integer Dim wzDelta As Integer Dim wX As Single, wY As Single wzDelta = HIWORD(wParam) wY = HIWORD(lParam) RaiseEvent WheelScroll(wShift, wzDelta, wX, wY)End Sub最后,就可以将定义的用户控件用在vb窗体编程中,实现对鼠标滚轮事件的监听和处理,测试主窗体如下:Option ExplicitDim KAs As LongDim KA1 As LongDim KA2 As LongPrivate Sub Picture1_Click()MWheel1.hWndCapture = Picture1.hWndMWheel1.EnableWheelEnd SubPrivate Sub List1_Click()MWheel2.hWndCapture = List1.hWndMWheel2.EnableWheelKA1 = List1.ListCountEnd SubPrivate Sub File1_Click()MWheel3.hWndCapture = File1.hWndMWheel3.EnableWheelKA1 = File1.ListCountEnd SubPrivate Sub MWheel2_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)If KAs > 0 ThenIf zDelta = 120 ThenKAs = KAs - 1List1.ListIndex = KAsEnd IfEnd IfIf KAs < KA1 - 1 ThenIf zDelta = -120 ThenKAs = KAs + 1List1.ListIndex = KAsEnd IfEnd IfEnd SubPrivate Sub MWheel1_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)If zDelta = 120 ThenKA2 = KA2 - 5Line1.Y1 = KA2Line1.Y2 = KA2End IfIf zDelta = -120 ThenKA2 = KA2 + 5Line1.Y1 = KA2Line1.Y2 = KA2End IfEnd SubPrivate Sub MWheel3_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)If KAs > 0 ThenIf zDelta = 120 ThenKAs = KAs - 1File1.ListIndex = KAsEnd IfEnd IfIf KAs < KA1 - 1 ThenIf zDelta = -120 ThenKAs = KAs + 1File1.ListIndex = KAsEnd IfEnd IfEnd Sub</SPAN>
2023-09-28 02:17:421