日韩无码专区无码一级三级片|91人人爱网站中日韩无码电影|厨房大战丰满熟妇|AV高清无码在线免费观看|另类AV日韩少妇熟女|中文日本大黄一级黄色片|色情在线视频免费|亚洲成人特黄a片|黄片wwwav色图欧美|欧亚乱色一区二区三区

RELATEED CONSULTING
相關(guān)咨詢
選擇下列產(chǎn)品馬上在線溝通
服務(wù)時(shí)間：8:30-17:00
你可能遇到了下面的問題
關(guān)閉右側(cè)工具欄

新聞中心

這里有您想知道的互聯(lián)網(wǎng)營銷解決方案
詳解VB.NET中鼠標(biāo)滾輪的實(shí)際應(yīng)用

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

成都創(chuàng)新互聯(lián)專注于企業(yè)營銷型網(wǎng)站建設(shè)、網(wǎng)站重做改版、同德網(wǎng)站定制設(shè)計(jì)、自適應(yīng)品牌網(wǎng)站建設(shè)、H5場(chǎng)景定制、商城網(wǎng)站建設(shè)、集團(tuán)公司官網(wǎng)建設(shè)、成都外貿(mào)網(wǎng)站制作、高端網(wǎng)站制作、響應(yīng)式網(wǎng)頁設(shè)計(jì)等建站業(yè)務(wù)，價(jià)格優(yōu)惠性價(jià)比高，為同德等各大城市提供網(wǎng)站開發(fā)制作服務(wù)。

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

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

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

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

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

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

鼠標(biāo)滾輪處理模塊(modWheel)

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

然后，定義用戶控件MWheel，實(shí)現(xiàn)對(duì)相關(guān)控件鼠標(biāo)滾輪事件的處理。

用戶控件（MWheel)代碼

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

最后，就可以將定義的用戶控件用在vb窗體編程中，實(shí)現(xiàn)對(duì)鼠標(biāo)滾輪事件的監(jiān)聽和處理，測(cè)試主窗體如下：

主窗體（Form1）代碼

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

代碼下載：http://files.cnblogs.com/lvjinjie/VB鼠標(biāo)滾動(dòng)輪應(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)于對(duì)話框制作技巧分享
  5. VB.NET事件訪問器特性介紹

網(wǎng)站欄目：詳解VB.NET中鼠標(biāo)滾輪的實(shí)際應(yīng)用
分享網(wǎng)址：http://www.5511xx.com/article/djdsscp.html