VB鼠标滚轮的应用实现

VB鼠标滚轮的应用实现

　　最近准备写一系列和工控、设备模拟仿真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 )  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

 

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

 

　　下篇文章：航空仪表模拟

 

 

 

posted on 2010-02-04 09:05  金杰 阅读( ...) 评论( ...) 编辑 收藏

转载于:https://www.cnblogs.com/lvjinjie/archive/2010/02/04/1660810.html