详解VB.NET中鼠标滚轮的实际应用

开发 后端
对于VB.NET中鼠标滚轮的使用,本文将从工控应用方面来进行具体阐述。希望本文能对大家有所帮助。

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

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

这一系列的文章主要以航空仪表模拟、步进电机控制、PLC交互和LED焊机的精确定位焊接控制等等作为例子,这些例子主要都是通过VB6.0实现的,但本人将以重原理轻语言的方式来进行叙述。

第一个例子很简单,就是一个和鼠标滚轮控制有关的例子,鼠标滚轮的控制在原来的VB6.0中可是不好控制的,呵呵,后续的例子正在整理中。

鼠标滚轮能给系统的使用带来很大便利,如使用滚轮移动选择这项,但在VB中的一些常用控件(如:文件框、列表框等)中没有提供鼠标滚轮滚动选择的效果。现将自己写的鼠标滚轮特效实现代码分享给大家:

本例子就是一个对Win32 API的调用,达到对ListBox、PictureBox等的鼠标滚轮控制。首先,申明windows API调用,将其放在模块modWheel中,以供用户控件使用。原理很简单,通过鼠标滚轮可以对如下白色的横线进行控制,效果图如下:

效果图

相关代码如下:

鼠标滚轮处理模块(modWheel)

  1. Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _  
  2.      (pDest As Any, pSource As Any, ByVal ByteLen As Long)  
  3.  
  4. Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _  
  5.      (ByVal hWnd As LongByVal nIndex As LongAs Long 
  6. Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _  
  7.      (ByVal hWnd As LongByVal nIndex As Long, _  
  8.      ByVal dwNewLong As LongAs Long 
  9. Public Const GWL_WNDPROC = (-4)  
  10. Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _  
  11.      (ByVal lpPrevWndFunc As LongByVal hWnd As Long, _  
  12.      ByVal Msg As LongByVal wParam As Long, _  
  13.      ByVal lParam As LongAs Long 
  14. Declare Function SetProp Lib "user32" Alias "SetPropA" _  
  15.      (ByVal hWnd As LongByVal lpString As String, _  
  16.      ByVal hData As LongAs Long 
  17. Declare Function GetProp Lib "user32" Alias "GetPropA" _  
  18.      (ByVal hWnd As LongByVal lpString As StringAs Long 
  19. Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _  
  20.      (ByVal hWnd As LongByVal lpString As StringAs Long 
  21. Declare Function GetParent Lib "user32" (ByVal hWnd As LongAs Long 
  22.  
  23. Public Const WM_MOUSEWHEEL = &H20A  
  24. Public Const WM_MOUSELAST = &H20A  
  25. Public Const WHEEL_DELTA = 120  
  26.  
  27.  
  28. Public Function HIWORD(LongIn As LongAs Integer 
  29.  
  30.    HIWORD = (LongIn And &HFFFF0000) \ &H10000  
  31. End Function 
  32. Public Function MWheelProc(ByVal hWnd As Long, _  
  33. ByVal wMsg As LongByVal wParam As Long, _  
  34. ByVal lParam As LongAs Long 
  35.  
  36.      Dim OldProc As Long 
  37.      Dim CtlWnd As Long 
  38.      Dim CtlPtr As Long 
  39.      Dim IntObj As Object 
  40.      Dim MWObject As MWheel  
  41.  
  42.      CtlWnd = GetProp(hWnd, "WheelWnd")  
  43.      CtlPtr = GetProp(CtlWnd, "WheelPtr")  
  44.      OldProc = GetProp(CtlWnd, "OldWheelProc")  
  45.  
  46.      If wMsg = WM_MOUSEWHEEL Then 
  47.           CopyMemory IntObj, CtlPtr, 4  
  48.           Set MWObject = IntObj  
  49.           MWObject.WndProc hWnd, wMsg, wParam, lParam  
  50.           Set MWObject = Nothing 
  51.           CopyMemory IntObj, 0&, 4  
  52.           Exit Function 
  53.     End If 
  54.  MWheelProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)  
  55. End Function 
  56.  
  57. Public Sub Subclass(MWCtl As MWheel, ParentWnd As Long)  
  58.      If GetProp(MWCtl.hWnd, "OldWheelProc") <> 0 Then 
  59.           Exit Sub 
  60.      End If 
  61.  
  62.      SetProp MWCtl.hWnd, "OldWheelProc", _  
  63.           GetWindowLong(ParentWnd, GWL_WNDPROC)  
  64.      
  65.      SetProp MWCtl.hWnd, "WheelPtr", ObjPtr(MWCtl)  
  66.      
  67.      SetProp ParentWnd, "WheelWnd", MWCtl.hWnd  
  68.  
  69.      SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc  
  70. End Sub 
  71.  
  72. Public Sub UnSubclass(MWCtl As MWheel, ParentWnd As Long)  
  73.      Dim OldProc As Long 
  74.  
  75.      OldProc = GetProp(MWCtl.hWnd, "OldWheelProc")  
  76.      If OldProc = 0 Then Exit Sub 
  77.     
  78.      SetWindowLong ParentWnd, GWL_WNDPROC, OldProc  
  79.      
  80.      RemoveProp ParentWnd, "WheelWnd" 
  81.      RemoveProp MWCtl.hWnd, "WheelPtr" 
  82.      RemoveProp MWCtl.hWnd, "OldWheelProc" 
  83. End Sub 

然后,定义用户控件MWheel,实现对相关控件鼠标滚轮事件的处理。 

用户控件(MWheel)代码

  1. Option Explicit  
  2.  
  3. Dim m_CapWnd As Long 
  4. Dim m_Subclassed As Boolean 
  5.  
  6. Event WheelScroll(Shift As Integer, zDelta As Integer, _  
  7.     X As Single, Y As Single)  
  8.  
  9. Private Sub UserControl_Resize()  
  10.      Size 32 * Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY  
  11. End Sub 
  12.  
  13. Public Sub DisableWheel()  
  14.      If m_CapWnd = 0 Then Exit Sub 
  15.      If m_Subclassed = False Then Exit Sub 
  16.  
  17.      UnSubclass Me, m_CapWnd  
  18.      m_Subclassed = False 
  19. End Sub 
  20.  
  21. Public Sub EnableWheel()  
  22.      If m_CapWnd = 0 Then Exit Sub 
  23.      m_Subclassed = True 
  24.      Subclass Me, m_CapWnd  
  25. End Sub 
  26.  
  27. Friend Property Get hWnd() As Long 
  28.      hWnd = UserControl.hWnd  
  29. End Property 
  30.  
  31. Public Property Get hWndCapture() As Long 
  32.      hWndCapture = m_CapWnd  
  33. End Property 
  34. Public Property Let hWndCapture(ByVal vNewValue As Long)  
  35.      m_CapWnd = vNewValue  
  36. End Property 
  37.  
  38. Friend Sub WndProc(ByVal hWnd As Long, _  
  39. ByVal wMsg As LongByVal wParam As LongByVal lParam As Long)  
  40.      Dim wShift As Integer 
  41.      Dim wzDelta As Integer 
  42.      Dim wX As Single, wY As Single     
  43.      wzDelta = HIWORD(wParam)  
  44.      
  45.      wY = HIWORD(lParam)  
  46.  
  47.      RaiseEvent WheelScroll(wShift, wzDelta, wX, wY)  
  48. End Sub 

最后,就可以将定义的用户控件用在vb窗体编程中,实现对鼠标滚轮事件的监听和处理,测试主窗体如下:

主窗体(Form1)代码

  1. Option Explicit  
  2. Dim KAs As Long 
  3. Dim KA1 As Long 
  4. Dim KA2 As Long 
  5. Private Sub Picture1_Click()  
  6. MWheel1.hWndCapture = Picture1.hWnd  
  7. MWheel1.EnableWheel  
  8. End Sub 
  9. Private Sub List1_Click()  
  10. MWheel2.hWndCapture = List1.hWnd  
  11. MWheel2.EnableWheel  
  12. KA1 = List1.ListCount  
  13. End Sub 
  14. Private Sub File1_Click()  
  15. MWheel3.hWndCapture = File1.hWnd  
  16. MWheel3.EnableWheel  
  17. KA1 = File1.ListCount  
  18. End Sub 
  19. Private Sub MWheel2_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)  
  20.  
  21. If KAs > 0 Then 
  22. If zDelta = 120 Then 
  23. KAs = KAs - 1  
  24. List1.ListIndex = KAs  
  25. End If 
  26. End If 
  27. If KAs < KA1 - 1 Then 
  28. If zDelta = -120 Then 
  29. KAs = KAs + 1  
  30. List1.ListIndex = KAs  
  31. End If 
  32. End If 
  33. End Sub 
  34. Private Sub MWheel1_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)  
  35.  
  36. If zDelta = 120 Then 
  37. KA2 = KA2 - 5  
  38. Line1.Y1 = KA2  
  39. Line1.Y2 = KA2  
  40. End If 
  41. If zDelta = -120 Then 
  42. KA2 = KA2 + 5  
  43. Line1.Y1 = KA2  
  44. Line1.Y2 = KA2  
  45.  
  46. End If 
  47. End Sub 
  48. Private Sub MWheel3_WheelScroll(Shift As Integer, zDelta As Integer, X As Single, Y As Single)  
  49.  
  50. If KAs > 0 Then 
  51. If zDelta = 120 Then 
  52. KAs = KAs - 1  
  53. File1.ListIndex = KAs  
  54. End If 
  55. End If 
  56. If KAs < KA1 - 1 Then 
  57. If zDelta = -120 Then 
  58. KAs = KAs + 1  
  59. File1.ListIndex = KAs  
  60. End If 
  61. End If 
  62. End Sub 

代码下载:http://files.cnblogs.com/lvjinjie/VB鼠标滚动轮应用案例.rar

【编辑推荐】

  1. VB.NET数据并发性具体处理方式
  2. VB.NET菜单组件的实现方案
  3. VB.NET运算符重载强大功能介绍
  4. VB.NET关于对话框制作技巧分享
  5. VB.NET事件访问器特性介绍

原文标题:VB鼠标滚轮的应用实现

链接:http://www.cnblogs.com/lvjinjie/archive/2010/02/04/1660810.html

 

责任编辑:彭凡 来源: 博客园
相关推荐

2010-01-14 10:35:34

VB.NET指针

2010-01-08 18:02:33

VB.NET事件

2010-01-15 13:30:53

VB.NET Tool

2010-01-11 16:15:13

VB.NET枚举功能

2010-01-07 15:57:02

VB.NET ForEach

2010-01-07 18:17:00

VB.NET连接SAP

2010-01-19 15:21:55

VB.NET区域性

2010-01-18 17:37:32

VB.NET文本框处理

2010-01-07 15:42:57

VB.NET WhilEnd While循环

2010-01-19 16:55:46

VB.NET声明语句

2010-01-18 18:50:26

VB.NET鼠标手势

2010-01-18 19:04:29

VB.NET组件叠加

2010-01-12 18:40:22

VB.NET Form

2010-01-21 17:34:48

VB.NET Bool

2009-10-20 17:38:54

VB.NET Comp

2010-01-12 18:35:43

VB.NET Stru

2010-01-08 15:22:22

VB.NET局部变量

2010-01-07 16:16:03

VB.NET变量作用域

2009-10-09 15:59:41

VB.NET对象

2010-01-12 16:20:44

VB.NET类
点赞
收藏

51CTO技术栈公众号