clssystray.cls

用VB写的一个代理服务器程序.rar复件 用VB写的一个代理服务器程序.rar

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSysTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False


#Const VB_VERSION = 6


Private Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

'常量
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

'API声明
Private Declare Function Shell_NotifyIcon Lib "shell32" _
                Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
                pnid As NOTIFYICONDATA) As Boolean

'本地变量
Private t As NOTIFYICONDATA
Private WithEvents pichook As PictureBox
Attribute pichook.VB_VarHelpID = -1
Private mvarToolTip As String

'事件
Public Event LButtonDown()
Public Event LButtonUp()
Public Event RButtonDblClk()
Public Event RButtonDown()
Public Event RButtonUp()

'本地变量,对应于类的属性
Private mvarSourceWindow As Form
Private mvarDefaultDblClk As Boolean

'*:********************************************************************************
'*: Tooltip Property
'*:********************************************************************************
Public Property Let ToolTip(ByVal vData As String)
    ChangeToolTip vData
End Property

Public Property Get ToolTip() As String
    ToolTip = mvarToolTip
End Property

'*:********************************************************************************
'*: Icon Property
'*:********************************************************************************
Public Property Let Icon(ByVal vData As Variant)
    ChangeIcon vData
End Property

Public Property Get Icon() As Variant
    Icon = t.hIcon      'pichook.Picture
End Property

'*:********************************************************************************
'*: DefaultDblClk Property
'*:********************************************************************************
Public Property Let DefaultDblClk(ByVal vData As Boolean)
    mvarDefaultDblClk = vData
End Property

Public Property Get DefaultDblClk() As Boolean
    DefaultDblClk = mvarDefaultDblClk
End Property

'*:********************************************************************************
'*: SourceWindow Property
'*:********************************************************************************
Public Property Set SourceWindow(ByVal vData As Form)
    Set mvarSourceWindow = vData
    SetPicHook
End Property

Public Property Get SourceWindow() As Form
    Set SourceWindow = mvarSourceWindow
End Property

'类初始化
Private Sub Class_Initialize()
    mvarDefaultDblClk = True
    
    t.cbSize = Len(t)
    t.uId = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.ucallbackMessage = WM_MOUSEMOVE
    t.hIcon = Me.Icon
    '默认无tooltip
    t.szTip = Chr$(0)
End Sub

'MouseMove事件响应代码
Private Sub pichook_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static rec As Boolean, msg As Long, oldmsg As Long
    
    oldmsg = msg
    msg = X / Screen.TwipsPerPixelX
   
    If rec = False Then
        rec = True
        Select Case msg
            Case WM_LBUTTONDBLCLK:
                '鼠标双击
                LButtonDblClk
            Case WM_LBUTTONDOWN:
                '激发鼠标左键按下事件
                RaiseEvent LButtonDown
            Case WM_LBUTTONUP:
                '激发鼠标左键抬起事件
                RaiseEvent LButtonUp
            Case WM_RBUTTONDBLCLK:
                '激发鼠标右键双击事件
                RaiseEvent RButtonDblClk
            Case WM_RBUTTONDOWN:
                '激发鼠标右键按下事件
                RaiseEvent RButtonDown
            Case WM_RBUTTONUP:
                '激发鼠标右键弹起事件
                RaiseEvent RButtonUp
        End Select
        rec = False
    End If
End Sub

Private Sub LButtonDblClk()
    '鼠标左键双击,则移去托盘图标
    If mvarDefaultDblClk Then
        mvarSourceWindow.WindowState = vbNormal
        mvarSourceWindow.Show
        App.TaskVisible = True
        RemoveFromSysTray
    End If
    
    RaiseEvent LButtonDblClk
End Sub

Public Sub RemoveFromSysTray()
    '移去托盘图标
    t.cbSize = Len(t)
    t.hwnd = pichook.hwnd
    t.uId = 1&
    Shell_NotifyIcon NIM_DELETE, t
End Sub

Public Sub IconInSysTray()
    '设置托盘图标
    Shell_NotifyIcon NIM_ADD, t
End Sub

Public Sub MinToSysTray()
    '最小化到托盘图标
    Me.IconInSysTray
    mvarSourceWindow.Hide
    App.TaskVisible = False
End Sub


'设置pichook
Private Sub SetPicHook()
On Error GoTo AlreadyAdded
#If VB_VERSION = 6 Then
    Set pichook = mvarSourceWindow.Controls.Add("VB.PictureBox", "pichook")
#Else
    Set pichook = mvarSourceWindow.pichook
#End If

    pichook.Visible = False
    pichook.Picture = mvarSourceWindow.Icon
    t.hwnd = pichook.hwnd
    Exit Sub

AlreadyAdded:
    If Err.Number <> 727 Then
       '已设置过pichook
       MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Error"
       Stop
       Resume
    End If
End Sub

Public Sub ChangeIcon(toNewIcon)
    '更换图标
    Set pichook.Picture = toNewIcon
    t.hIcon = pichook.Picture
    Shell_NotifyIcon NIM_MODIFY, t
End Sub

Public Sub ChangeToolTip(ByVal cNewTip As String)
    '更换tooltip
    mvarToolTip = cNewTip
    t.szTip = cNewTip & Chr$(0)
    Shell_NotifyIcon NIM_MODIFY, t
    If mvarSourceWindow.WindowState = vbMinimized Then
        mvarSourceWindow.Caption = cNewTip
    End If
End Sub