home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / RedHat_Win185020282005.psc / CTrackMouse.cls < prev    next >
Text File  |  2004-09-05  |  4KB  |  132 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CTrackMouse"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private bTracking As Boolean
  17.  
  18. Private mTrackObject As Object
  19.  
  20. Private procPrevWndFunc As Long
  21.  
  22. Private Const WM_MOUSEHOVER = &H2A1&
  23. Private Const WM_MOUSELEAVE = &H2A3&
  24.  
  25. Private Const WM_MOUSEMOVE = &H200
  26.  
  27. Private Const WM_LBUTTONDBLCLK As Integer = &H203
  28. Private Const WM_LBUTTONDOWN As Integer = &H201
  29. Private Const WM_LBUTTONUP  As Integer = &H202
  30. Private Const WM_MBUTTONDBLCLK  As Integer = &H209
  31. Private Const WM_MBUTTONDOWN  As Integer = &H207
  32. Private Const WM_MBUTTONUP  As Integer = &H208
  33. Private Const WM_MOUSEACTIVATE  As Integer = &H21
  34. Private Const WM_MOUSEFIRST  As Integer = &H200
  35. Private Const WM_MOUSELAST  As Integer = &H209
  36. Private Const WM_RBUTTONDBLCLK  As Integer = &H206
  37. Private Const WM_RBUTTONDOWN  As Integer = &H204
  38. Private Const WM_RBUTTONUP  As Integer = &H205
  39.  
  40. Private Const TME_HOVER = &H1&
  41. Private Const TME_LEAVE = &H2&
  42. Private Const TME_QUERY = &H40000000
  43. Private Const TME_CANCEL = &H80000000
  44.  
  45. Private Const HOVER_DEFAULT = &HFFFFFFFF
  46. Private Const GWL_WNDPROC = -4
  47.  
  48. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  49. Private 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
  50. Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTINFO) As Long
  51.  
  52. Private Type TRACKMOUSEEVENTINFO
  53.     cbSize As Long
  54.     dwFlags As Long
  55.     hwndTrack As Long
  56.     dwHoverTime As Long
  57. End Type
  58.  
  59. Public Event MouseOver()
  60. Public Event MouseOut()
  61. Public Event MouseLeftDown()
  62. Public Event MouseLeftUp()
  63. Friend Function MessageReceived(ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  64. Select Case wMsg
  65.     Case WM_MOUSELEAVE
  66.         RaiseEvent MouseOut
  67.     Case WM_MOUSEHOVER
  68.         RaiseEvent MouseOver
  69.     Case WM_MOUSEMOVE
  70.         StartTracking
  71.     Case WM_LBUTTONDOWN
  72.         RaiseEvent MouseLeftDown
  73.     Case WM_LBUTTONUP
  74.         RaiseEvent MouseLeftUp
  75. End Select
  76. 'StartTracking
  77. MessageReceived = CallWindowProc(procPrevWndFunc, mTrackObject.hWnd, wMsg, wParam, lParam)
  78. End Function
  79.  
  80. Public Function StartTracking() As Boolean
  81. If mTrackObject Is Nothing Then
  82.     StartTracking = False
  83. Else
  84.     If bTracking = True Then StopTracking
  85.     Dim hWnd As Long
  86.     hWnd = mTrackObject.hWnd
  87.     colTrackMouse.Add Me, "TM" & hWnd 'so procTrackMouse knows which instance of the class to call
  88.     procPrevWndFunc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf procTrackMouse)
  89.     Dim tme As TRACKMOUSEEVENTINFO
  90.     With tme
  91.         .cbSize = Len(tme)
  92.         .dwFlags = TME_HOVER Or TME_LEAVE
  93.         .dwHoverTime = 1 'HOVER_DEFAULT
  94.         .hwndTrack = hWnd
  95.     End With
  96.     TrackMouseEvent tme
  97.     bTracking = True
  98. End If
  99. End Function
  100.  
  101.  
  102. Public Function StopTracking() As Boolean
  103. If Not (mTrackObject Is Nothing) Then
  104.     Dim hWnd As Long
  105.     hWnd = mTrackObject.hWnd
  106.     SetWindowLong hWnd, GWL_WNDPROC, procPrevWndFunc
  107.     On Error Resume Next
  108.     colTrackMouse.Remove "TM" & hWnd
  109.     bTracking = False
  110. End If
  111. End Function
  112. Property Get TrackObject() As Object
  113. Set TrackObject = mTrackObject
  114. End Property
  115.  
  116. Property Set TrackObject(obj As Object)
  117. If obj Is Nothing Then
  118.     StopTracking
  119.     Set mTrackObject = Nothing
  120. Else
  121.     Set mTrackObject = obj
  122.     StartTracking
  123. End If
  124. End Property
  125.  
  126. Private Sub Class_Terminate()
  127. Set TrackObject = Nothing
  128. End Sub
  129.  
  130.  
  131.  
  132.