VB鼠标滚轮的应用实现

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

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

 

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

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

 

　　本例子就是一个对Win32 API的调用，达到对ListBox、PictureBox等的鼠标滚轮控制。首先，申明windows API调用，将其放在模块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，实现对相关控件鼠标滚轮事件的处理。 

 

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窗体编程中，实现对鼠标滚轮事件的监听和处理，测试主窗体如下：

 

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

 

　　代码下载：VB鼠标滚动轮应用案例

 

　　下篇文章：航空仪表模拟