本文將從現(xiàn)實(shí)開發(fā)的角度為大家講解VB.NET鼠標(biāo)滾輪的使用，希望這樣實(shí)用的文章能對大家有所幫助。

最近準(zhǔn)備寫一系列和工控、設(shè)備模擬仿真PC機(jī)軟件有關(guān)的文章，主要是對若干年和軟件有關(guān)的工作進(jìn)行總結(jié)，感興趣的朋友可以關(guān)注一下。

這一系列的文章主要以航空儀表模擬、步進(jìn)電機(jī)控制、PLC交互和LED焊機(jī)的精確定位焊接控制等等作為例子，這些例子主要都是通過VB6.0實(shí)現(xiàn)的，但本人將以重原理輕語言的方式來進(jìn)行敘述。

第一個例子很簡單，就是一個和鼠標(biāo)滾輪控制有關(guān)的例子，鼠標(biāo)滾輪的控制在原來的VB6.0中可是不好控制的，呵呵，后續(xù)的例子正在整理中。

鼠標(biāo)滾輪能給系統(tǒng)的使用帶來很大便利，如使用滾輪移動選擇這項(xiàng)，但在VB中的一些常用控件（如：文件框、列表框等）中沒有提供鼠標(biāo)滾輪滾動選擇的效果?，F(xiàn)將自己寫的鼠標(biāo)滾輪特效實(shí)現(xiàn)代碼分享給大家：

本例子就是一個對Win32 API的調(diào)用，達(dá)到對ListBox、PictureBox等的鼠標(biāo)滾輪控制。首先，申明windows API調(diào)用，將其放在模塊modWheel中，以供用戶控件使用。原理很簡單，通過鼠標(biāo)滾輪可以對如下白色的橫線進(jìn)行控制，效果圖如下：

相關(guān)代碼如下：

鼠標(biāo)滾輪處理模塊(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，實(shí)現(xiàn)對相關(guān)控件鼠標(biāo)滾輪事件的處理。 

用戶控件（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窗體編程中，實(shí)現(xiàn)對鼠標(biāo)滾輪事件的監(jiān)聽和處理，測試主窗體如下：

主窗體（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 

代碼下載：http://files.cnblogs.com/lvjinjie/VB鼠標(biāo)滾動輪應(yīng)用案例.rar

【編輯推薦】

1. VB.NET數(shù)據(jù)并發(fā)性具體處理方式
2. VB.NET菜單組件的實(shí)現(xiàn)方案
3. VB.NET運(yùn)算符重載強(qiáng)大功能介紹
4. VB.NET關(guān)于對話框制作技巧分享
5. VB.NET事件訪問器特性介紹

原文標(biāo)題：VB鼠標(biāo)滾輪的應(yīng)用實(shí)現(xiàn)

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