明晨网络

电话： 136-6532-7492 QQ: 给我发送消息 8507-0741

VB代码：让控件支持鼠标移入移出MouseOver事件

admin，2009-06-12 19:39， 文章标签: VB MouseOver

    html中支持mouseover事件，但是vb中没有，很多时候我们迫切需要这样的功能，比如鼠标划过时，让picturebox改变背景图片，划出时再恢复。这里给出明晨网络的解决办法。这段代码比较啰嗦，有更好的思路烦请指点。
    如果绑定一个无标题的Form对象的句柄，通过Resize和SetPointer方法，可以改变窗体大小及拖动窗体

    使用方法如下：

  1. '支持任何有句柄的控件，这里以名称为Pic_Skin_CMD_Close的Picturebox为例，别忘了在Form_Load中使用Set Mouse = New Cls_MouseOver来实例化
  2. Private WithEvents Mouse As Cls_MouseOver
  3.  
  4. '在目标控件的MouseMove事件中绑定句柄
  5. '如果有其他控件要支持Mouse_Over，也在MouseMove事件中绑定句柄，可以随时随意绑定N个句柄
  6. Private Sub Pic_Skin_CMD_Close_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  7.     Mouse.BindMouseOver Pic_Skin_CMD_Close.hWnd
  8. End Sub
  9.  
  10. '========================================
  11. '函数名称：Mouse_Over
  12. '函数作用：鼠标滑过控件事件，FillwithPic是明晨网络Mingchennet.COM自定义的图片载入函数，可以注释掉换成自己的代码
  13. '========================================
  14. Private Sub Mouse_Over(ByVal hWnd As Long, ByVal Enter As Boolean)
  15.     Select Case hWnd
  16.     Case Pic_Skin_CMD_Close.hWnd
  17.         If Enter Then
  18.             FillwithPic Pic_Skin_CMD_Close, LoadPicture(Skin_Ctrl_Form_Close_Over)
  19.         Else
  20.             FillwithPic Pic_Skin_CMD_Close, LoadPicture(Skin_Ctrl_Form_Close)
  21.         End If
  22.     End Select
  23. End Sub

Cls_MouseOver类模块，代码比较长

 

  1. Option Explicit  
  2.    
  3. Private WithEvents Timer As clsXTimer  
  4.    
  5.    
  6.    
  7.     '========================================  
  8.    '声明作用：获取坐标  
  9.    '========================================  
  10. 'Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long  
  11. 'Private Type POINTAPI  
  12. '    X As Long  
  13. '    Y As Long  
  14. 'End Type  
  15. 'Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long  
  16.    
  17. 'Private Type RECT  
  18. '    Left As Long  
  19. '    Top As Long  
  20. '    Right As Long  
  21. '    Bottom As Long  
  22. 'End Type  
  23.    
  24. Private Declare Function ReleaseCapture Lib "user32" () As Long 
  25. Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long 
  26. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 
  27. Private Const HTCAPTION = 2  
  28. Private Const WM_NCLBUTTONDOWN = &HA1  
  29. Private Const HTLEFT = 10  
  30. Private Const HTRIGHT = 11  
  31. Private Const HTTOP = 12  
  32. Private Const HTTOPLEFT = 13  
  33. Private Const HTTOPRIGHT = 14  
  34. Private Const HTBOTTOM = 15  
  35. Private Const HTBOTTOMLEFT = 16  
  36. Private Const HTRIGHTBOTTOM = 17  
  37.    
  38. '所要执行的动作变量，是移动还是改变大小及从哪个方向改变大小  
  39. Private Action As String 
  40.     '========================================  
  41.    '声明作用：获取坐标  
  42.    '========================================  
  43. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As Rect) As Long 
  44. Private Type PointApi  
  45.     X As Long 
  46.     Y As Long 
  47. End Type  
  48. Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointApi) As Long 
  49.    
  50. Private Type Rect  
  51.     Left As Long 
  52.     Top As Long 
  53.     Right As Long 
  54.     Bottom As Long 
  55. End Type  
  56.    
  57.     '========================================  
  58.    '声明作用：坐标快照  
  59.    '========================================  
  60. Private Type StationCapture  
  61.     hWnd As Long    '句柄  
  62.    In As Boolean   '鼠标是否在窗体上面  
  63. End Type  
  64.    
  65.     '========================================  
  66.    '声明作用：鼠标趋势  
  67.    '========================================  
  68. Private Type MouseDirect  
  69.     hWnd As Long        '句柄  
  70.    Moved As Boolean    '是否运动  
  71.    Enter As Boolean    '是否进入，否则为退出  
  72. End Type  
  73.    
  74.    
  75. Private CurrenHWnd As Long 
  76.    
  77.    
  78.     '========================================  
  79.    '声明作用：鼠标滑过事件  
  80.    '========================================  
  81. Public Event Over(ByVal hWnd As Long, ByVal Enter As Boolean)  
  82.    
  83.    
  84. '========================================  
  85. '函数名称：Resize  
  86. '函数作用：改变有句柄的目标窗体的大小  
  87. '========================================  
  88. Public Sub Resize(ByVal hWnd As Long)  
  89.     '为当前的应用程序释放鼠标捕获  
  90.    ReleaseCapture  
  91.    
  92.     Select Case Action  
  93.     Case "Left" 
  94.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTLEFT, 0  
  95.     Case "Right" 
  96.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTRIGHT, 0  
  97.     Case "Up" 
  98.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTTOP, 0  
  99.     Case "LeftUp" 
  100.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTTOPLEFT, 0  
  101.     Case "RightUp" 
  102.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTTOPRIGHT, 0  
  103.     Case "Down" 
  104.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0  
  105.     Case "LeftDown" 
  106.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0  
  107.     Case "RightDown" 
  108.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTRIGHTBOTTOM, 0  
  109.     Case "Move" 
  110.         SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0  
  111. End Select 
  112.    
  113.    
  114. End Sub 
  115.    
  116. '========================================  
  117. '函数名称：SetPointer  
  118. '函数作用：设置鼠标指针样式  
  119. '========================================  
  120. Public Sub SetPointer(ByVal hWnd As Long)  
  121.     Dim MyRect As Rect  
  122.     Dim MyPoint As PointApi  
  123.    
  124.     ' MyRect返回当前窗口位置  
  125.    Call GetWindowRect(hWnd, MyRect)  
  126.    
  127.     ' MyPoint返回当前鼠标位置  
  128.    Call GetCursorPos(MyPoint)  
  129.    
  130.     Select Case True 
  131.     '鼠标位于窗体左上方  
  132.    
  133.     Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y < MyRect.Top + 5  
  134.     Screen.MousePointer = vbSizeNWSE  
  135.    
  136.     Action = "LeftUp" 
  137.     '鼠标位于窗体右下方  
  138.    
  139.     Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y > MyRect.Bottom - 5  
  140.     Screen.MousePointer = vbSizeNWSE  
  141.    
  142.     Action = "RightDown" 
  143.     '鼠标位于窗体右上方  
  144.    
  145.     Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y < MyRect.Top + 5  
  146.     '45度双向鼠标指针  
  147.    
  148.     Screen.MousePointer = vbSizeNESW  
  149.     Action = "RightUp" 
  150.    
  151.     '鼠标位于窗体左下方  
  152.    Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y > MyRect.Bottom - 5  
  153.    
  154.     Screen.MousePointer = vbSizeNESW  
  155.     Action = "LeftDown" 
  156.    
  157.     '鼠标位于窗体左边  
  158.    Case MyPoint.X < MyRect.Left + 5  
  159.    
  160.     '水平双向鼠标指针  
  161.    Screen.MousePointer = vbSizeWE  
  162.    
  163.     Action = "Left" 
  164.     '鼠标位于窗体右边  
  165.    
  166.     Case MyPoint.X > MyRect.Right - 5  
  167.     Screen.MousePointer = vbSizeWE  
  168.    
  169.     Action = "Right" 
  170.     '鼠标位于窗体上方  
  171.    
  172.     Case MyPoint.Y < MyRect.Top + 5  
  173.     '垂直双向鼠标指针  
  174.    
  175.     Screen.MousePointer = vbSizeNS  
  176.     Action = "Up" 
  177.    
  178.     '鼠标位于窗体下方  
  179.    Case MyPoint.Y > MyRect.Bottom - 5  
  180.    
  181.     Screen.MousePointer = vbSizeNS  
  182.     Action = "Down" 
  183.      
  184.     '鼠标位于窗体顶部以下，移动区以上  
  185.    Case MyPoint.Y > MyRect.Top + 5 And MyPoint.Y <= MyRect.Top + 20  
  186.         '默认鼠标指针  
  187.        Screen.MousePointer = 0  
  188.         Action = "Move" 
  189.     '鼠标位于窗体其他位置  
  190.    Case Else 
  191.         Screen.MousePointer = 0  
  192.         Action = "" 
  193.     End Select 
  194. End Sub 
  195.    
  196. '========================================  
  197. '函数名称：SetSC  
  198. '函数作用：建立坐标快照  
  199. '========================================  
  200. Private Function SetSC(ByVal hWnd As Long) As StationCapture  
  201.     Dim tPoint As PointApi  
  202.     Dim tRect As Rect  
  203.      
  204.     GetCursorPos tPoint  
  205.     GetWindowRect hWnd, tRect  
  206.      
  207.     SetSC.hWnd = hWnd  
  208.      
  209.     If tRect.Left < tPoint.X And tPoint.X < tRect.Right And tRect.Top < tPoint.Y And tPoint.Y < tRect.Bottom Then 
  210.         SetSC.In = True 
  211.     Else 
  212.         SetSC.In = False 
  213.     End If 
  214. End Function 
  215.    
  216.    
  217.    
  218.    
  219. '========================================  
  220. '函数名称：CreateEvent  
  221. '函数作用：事件通知,该事件需要被触发，一般通过50ms的定时器来实现  
  222. '========================================  
  223. Public Sub CreateEvent()  
  224.     '建立坐标快照  
  225.    Dim SC As StationCapture  
  226.      
  227.     Static LastSC As StationCapture  
  228.      
  229.     SC = SetSC(CurrenHWnd)  
  230.      
  231.     '如果是同一个控件，则判断鼠标移动是否超出控件范围  
  232.    If SC.hWnd = LastSC.hWnd Then 
  233.          
  234.          
  235.         If SC.In And LastSC.In = False Then 
  236.             RaiseEvent Over(CurrenHWnd, True)  
  237.         ElseIf SC.In = False And LastSC.In Then 
  238.             RaiseEvent Over(CurrenHWnd, False)  
  239.         End If 
  240.     Else 
  241.         If SC.In Then 
  242.             If LastSC.hWnd <> 0 Then 
  243.                 '从其他控件退出，进入到当前控件  
  244.                RaiseEvent Over(LastSC.hWnd, False)  
  245.                 RaiseEvent Over(CurrenHWnd, True)  
  246.             Else 
  247.                 '从未知控件（空白区）进入  
  248.                RaiseEvent Over(CurrenHWnd, True)  
  249.             End If 
  250.              
  251.              
  252.         End If 
  253.          
  254.          
  255.     End If 
  256.      
  257.      
  258.    
  259.      
  260.     LastSC = SC  
  261. End Sub 
  262.    
  263. '========================================  
  264. '函数名称：BindMouseOver  
  265. '函数作用：设置要监控的控件句柄  
  266. '========================================  
  267. Public Sub BindMouseOver(ByVal hWnd As Long)  
  268.     CurrenHWnd = hWnd  
  269. End Sub 
  270.    
  271.    
  272.    
  273.    
  274. Private Sub Class_Initialize()  
  275.     '这个类模块定时器用来监视鼠标轨迹，如果使用VB自带的TIMER控件来计时，可以注释本过程  
  276.    Set Timer = New clsXTimer  
  277.     Timer.Interval = 50  
  278.     Timer.Enabled = True 
  279. End Sub 
  280.    
  281. Private Sub Class_Terminate()  
  282.     '这个类模块定时器用来监视鼠标轨迹，如果使用VB自带的TIMER控件来计时，可以注释本过程  
  283.    Timer.Enabled = False 
  284.     Set Timer = Nothing 
  285. End Sub 
  286.    
  287. '这个类模块定时器用来监视鼠标轨迹，如果使用VB自带的TIMER控件来计时，可以注释本过程  
  288. '通过窗体的TIMER控件，间隔50ms来执行CreateEvent也可以  
  289. Private Sub Timer_Tick()  
  290.     CreateEvent  
  291. End Sub 

 

文章源自:明晨网络，admin，《VB代码：让控件支持鼠标移入移出MouseOver事件》，http://www.mingchennet.com/tec/code/vb/31.htm