ctrackmouse.cls

防红帽子的shell 我是从别处下的,喜欢的朋友自已

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CTrackMouse"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2006/11/10
'描    述：仿红帽子操作系统Shell
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Option Explicit

Private bTracking As Boolean

Private mTrackObject As Object

Private procPrevWndFunc As Long

Private Const WM_MOUSEHOVER = &H2A1&
Private Const WM_MOUSELEAVE = &H2A3&

Private Const WM_MOUSEMOVE = &H200

Private Const WM_LBUTTONDBLCLK As Integer = &H203
Private Const WM_LBUTTONDOWN As Integer = &H201
Private Const WM_LBUTTONUP  As Integer = &H202
Private Const WM_MBUTTONDBLCLK  As Integer = &H209
Private Const WM_MBUTTONDOWN  As Integer = &H207
Private Const WM_MBUTTONUP  As Integer = &H208
Private Const WM_MOUSEACTIVATE  As Integer = &H21
Private Const WM_MOUSEFIRST  As Integer = &H200
Private Const WM_MOUSELAST  As Integer = &H209
Private Const WM_RBUTTONDBLCLK  As Integer = &H206
Private Const WM_RBUTTONDOWN  As Integer = &H204
Private Const WM_RBUTTONUP  As Integer = &H205

Private Const TME_HOVER = &H1&
Private Const TME_LEAVE = &H2&
Private Const TME_QUERY = &H40000000
Private Const TME_CANCEL = &H80000000

Private Const HOVER_DEFAULT = &HFFFFFFFF
Private Const GWL_WNDPROC = -4

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTINFO) As Long

Private Type TRACKMOUSEEVENTINFO
    cbSize As Long
    dwFlags As Long
    hwndTrack As Long
    dwHoverTime As Long
End Type

Public Event MouseOver()
Public Event MouseOut()
Public Event MouseLeftDown()
Public Event MouseLeftUp()
Friend Function MessageReceived(ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
    Case WM_MOUSELEAVE
        RaiseEvent MouseOut
    Case WM_MOUSEHOVER
        RaiseEvent MouseOver
    Case WM_MOUSEMOVE
        StartTracking
    Case WM_LBUTTONDOWN
        RaiseEvent MouseLeftDown
    Case WM_LBUTTONUP
        RaiseEvent MouseLeftUp
End Select
'StartTracking
MessageReceived = CallWindowProc(procPrevWndFunc, mTrackObject.hwnd, wMsg, wParam, lParam)
End Function

Public Function StartTracking() As Boolean
If mTrackObject Is Nothing Then
    StartTracking = False
Else
    If bTracking = True Then StopTracking
    Dim hwnd As Long
    hwnd = mTrackObject.hwnd
    colTrackMouse.Add Me, "TM" & hwnd 'so procTrackMouse knows which instance of the class to call
    procPrevWndFunc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf procTrackMouse)
    Dim tme As TRACKMOUSEEVENTINFO
    With tme
        .cbSize = Len(tme)
        .dwFlags = TME_HOVER Or TME_LEAVE
        .dwHoverTime = 1 'HOVER_DEFAULT
        .hwndTrack = hwnd
    End With
    TrackMouseEvent tme
    bTracking = True
End If
End Function


Public Function StopTracking() As Boolean
If Not (mTrackObject Is Nothing) Then
    Dim hwnd As Long
    hwnd = mTrackObject.hwnd
    SetWindowLong hwnd, GWL_WNDPROC, procPrevWndFunc
    On Error Resume Next
    colTrackMouse.Remove "TM" & hwnd
    bTracking = False
End If
End Function
Property Get TrackObject() As Object
Set TrackObject = mTrackObject
End Property

Property Set TrackObject(obj As Object)
If obj Is Nothing Then
    StopTracking
    Set mTrackObject = Nothing
Else
    Set mTrackObject = obj
    StartTracking
End If
End Property

Private Sub Class_Terminate()
Set TrackObject = Nothing
End Sub