在VB.NET中鼠标滚轮的实际应用相关讲解

本文将从现实开发的角度为大家讲解VB.NET鼠标滚轮的使用，希望这样实用的文章能对大家有所帮助。        

最近准备写一系列和工控、设备模拟仿真PC机软件有关的文章，主要是对若干年和软件有关的工作进行总结，感兴趣的朋友可以关注一下。        

这一系列的文章主要以航空仪表模拟、步进电机控制、PLC交互和LED焊机的精确定位焊接控制等等作为例子，这些例子主要都是通过VB6.0实现的，但本人将以重原理轻语言的方式来进行叙述。         第一个例子很简单，就是一个和鼠标滚轮控制有关的例子，鼠标滚轮的控制在原来的VB6.0中可是不好控制的，呵呵，后续的例子正在整理中。健康知识平台重庆肾结石哪家医院好   

鼠标滚轮能给系统的使用带来很大便利，如使用滚轮移动选择这项，但在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）   更多http://zhieyuoa.blog.chinaunix.net   

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 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窗体编程中，实现对鼠标滚轮事件的监听和处理，测试主窗体如下：         主窗体（Form1）代码         Option Explicit         Dim KAs As Long         Dim KA1 As Long         Dim KA2 As Long         Private Sub Picture1_Click（）         MWheel1.hWndCapture = Picture1.hWnd         MWheel1.EnableWheel         End Sub Private Sub List1_Click（）         MWheel2.hWndCapture = List1.hWnd         MWheel2.EnableWheel         KA1 = List1.ListCount         End Sub Private Sub File1_Click（）         MWheel3.hWndCapture = File1.hWnd         MWheel3.EnableWheel         KA1 = File1.ListCount         End Sub         Private Sub         MWheel2_WheelScroll（Shift As Integer, zDelta As Integer, X As Single, Y As Single）         If KAs > 0 Then If zDelta = 120 Then KAs = KAs - 1  List1.ListIndex = KAs         End If End If If KAs < KA1 - 1 Then If zDelta = -120 Then KAs = KAs + 1         List1.ListIndex = KAs         End If End         If End Sub Private Sub MWheel1_WheelScroll（Shift As Integer, zDelta As Integer, X As Single, Y As Single）         If zDelta = 120         Then KA2 = KA2 - 5  Line1.Y1 = KA2         Line1.Y2 = KA2         End If If zDelta = -120 Then KA2 = KA2 + 5  Line1.Y1 = KA2         Line1.Y2 = KA2         End If End Sub Private Sub MWheel3_WheelScroll（Shift As Integer, zDelta As Integer, X As Single, Y As Single）         If KAs > 0         Then If zDelta = 120         Then KAs = KAs - 1         File1.ListIndex = KAs         End If         End If If KAs < KA1 - 1 Then If zDelta = -120 Then KAs = KAs + 1  File1.ListIndex = KAs         End If         End If         End Sub