建站
咨詢
售后
建站咨詢
新聞中心
這里有您想知道的互聯(lián)網(wǎng)營銷解決方案
詳解VB.NET中鼠標滾輪的實際應用
本文將從現(xiàn)實開發(fā)的角度為大家講解VB.NET鼠標滾輪的使用，希望這樣實用的文章能對大家有所幫助。
成都創(chuàng)新互聯(lián)專注于企業(yè)營銷型網(wǎng)站建設、網(wǎng)站重做改版、同德網(wǎng)站定制設計、自適應品牌網(wǎng)站建設、H5場景定制、商城網(wǎng)站建設、集團公司官網(wǎng)建設、成都外貿網(wǎng)站制作、高端網(wǎng)站制作、響應式網(wǎng)頁設計等建站業(yè)務，價格優(yōu)惠性價比高，為同德等各大城市提供網(wǎng)站開發(fā)制作服務。
最近準備寫一系列和工控、設備模擬仿真PC機軟件有關的文章，主要是對若干年和軟件有關的工作進行總結，感興趣的朋友可以關注一下。
這一系列的文章主要以航空儀表模擬、步進電機控制、PLC交互和LED焊機的精確定位焊接控制等等作為例子，這些例子主要都是通過VB6.0實現(xiàn)的，但本人將以重原理輕語言的方式來進行敘述。
第一個例子很簡單，就是一個和鼠標滾輪控制有關的例子，鼠標滾輪的控制在原來的VB6.0中可是不好控制的，呵呵，后續(xù)的例子正在整理中。
鼠標滾輪能給系統(tǒng)的使用帶來很大便利，如使用滾輪移動選擇這項，但在VB中的一些常用控件（如：文件框、列表框等）中沒有提供鼠標滾輪滾動選擇的效果。現(xiàn)將自己寫的鼠標滾輪特效實現(xiàn)代碼分享給大家：
本例子就是一個對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，實現(xiàn)對相關控件鼠標滾輪事件的處理。
用戶控件（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窗體編程中，實現(xiàn)對鼠標滾輪事件的監(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鼠標滾動輪應用案例.rar
【編輯推薦】
- VB.NET數(shù)據(jù)并發(fā)性具體處理方式
- VB.NET菜單組件的實現(xiàn)方案
- VB.NET運算符重載強大功能介紹
- VB.NET關于對話框制作技巧分享
- VB.NET事件訪問器特性介紹
當前名稱：詳解VB.NET中鼠標滾輪的實際應用
文章轉載：http://www.dlmjj.cn/article/djdsscp.html
