vbchinasystray.ctl

星级酒店管理系统（附带系统自写控件源码）

VERSION 5.00
Begin VB.UserControl SysTray 
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   CanGetFocus     =   0   'False
   ClientHeight    =   480
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   495
   ClipControls    =   0   'False
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   480
   ScaleWidth      =   495
   ToolboxBitmap   =   "VBChinaSysTray.ctx":0000
   Begin VB.Image Image1 
      Appearance      =   0  'Flat
      BorderStyle     =   1  'Fixed Single
      Height          =   435
      Left            =   0
      Picture         =   "VBChinaSysTray.ctx":0312
      Top             =   15
      Width           =   510
   End
End
Attribute VB_Name = "SysTray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

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 NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

' 鼠标事件常量
Private Const WM_MOUSEMOVE = &H200
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
Private Const WM_MOUSEOVER = &H200

Private Declare Function Shell_NotifyIcon Lib "shell32" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

' API类型
Dim nid As NOTIFYICONDATA

' 缺省属性值
Const m_def_Visible = False
Const m_def_ToolTip = "VB中国托盘图标"

' 属性变量
Dim m_Visible As Boolean
Dim m_ToolTip As String
Dim m_Icon As Picture

' 事件定义
Event MouseMove()
Event MouseDown(Button As Integer)
Event MouseUp(Button As Integer)
Event DblClick()    'MappingInfo=UserControl,UserControl,-1,DblClick

Public Property Get Icon() As Picture

     Set Icon = m_Icon
     
End Property

Public Property Set Icon(ByVal New_Icon As Picture)

     Set m_Icon = New_Icon
    If New_Icon Is Nothing Then
        Visible = False
    Else
        If m_Visible Then
            nid.uFlags = NIF_ICON
            nid.hIcon = m_Icon
            Shell_NotifyIcon NIM_MODIFY, nid
        End If
    End If
    PropertyChanged "Icon"
    
End Property

Public Property Get ToolTip() As String

    ToolTip = m_ToolTip
    
End Property

Public Property Let ToolTip(ByVal New_ToolTip As String)
    m_ToolTip = Trim(New_ToolTip)
    nid.uFlags = NIF_TIP
    nid.szTip = m_ToolTip & vbNullChar
    Shell_NotifyIcon NIM_MODIFY, nid
    PropertyChanged "ToolTip"
End Property

' 属性初始化
Private Sub UserControl_InitProperties()
    
    Set m_Icon = LoadPicture("")
    m_ToolTip = m_def_ToolTip
    m_Visible = m_def_Visible
    
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    Set m_Icon = PropBag.ReadProperty("Icon", Nothing)
    m_ToolTip = PropBag.ReadProperty("ToolTip", m_def_ToolTip)
    m_Visible = PropBag.ReadProperty("Visible", m_def_Visible)
    
End Sub

Private Sub UserControl_Resize()
    
    Static inloop As Boolean
    
    If inloop Then Exit Sub
       inloop = True
       Height = Image1.Height
       Width = Image1.Width
       inloop = False
    
End Sub

Private Sub UserControl_Terminate()
    
    Shell_NotifyIcon NIM_DELETE, nid  '删除托盘图标
    
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    
    Call PropBag.WriteProperty("Icon", m_Icon, Nothing)
    Call PropBag.WriteProperty("ToolTip", m_ToolTip, m_def_ToolTip)
    Call PropBag.WriteProperty("Visible", m_Visible, m_def_Visible)
    
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    Select Case x / Screen.TwipsPerPixelX
    Case WM_LBUTTONDBLCLK
        RaiseEvent DblClick
    Case WM_LBUTTONDOWN
        RaiseEvent MouseDown(vbLeftButton)
    Case WM_LBUTTONUP
        RaiseEvent MouseUp(vbLeftButton)
    Case WM_RBUTTONDBLCLK
        RaiseEvent DblClick
    Case WM_RBUTTONDOWN
        RaiseEvent MouseDown(vbRightButton)
    Case WM_RBUTTONUP
        RaiseEvent MouseUp(vbRightButton)
    Case WM_MOUSEOVER
        RaiseEvent MouseMove
    End Select
    
End Sub

Public Property Get Visible() As Boolean
Attribute Visible.VB_MemberFlags = "400"

    Visible = m_Visible
    
End Property

Public Property Let Visible(ByVal New_Visible As Boolean)
    
    If m_Visible = New_Visible Then Exit Property
    m_Visible = New_Visible
    If m_Visible Then
        If Ambient.UserMode Then
            nid.cbSize = Len(nid)
            nid.hwnd = UserControl.hwnd
            nid.UID = Int((Rnd * 65535) + 1)
            nid.uFlags = NIF_MESSAGE
            If Not m_Icon Is Nothing Then
                nid.uFlags = nid.uFlags + NIF_ICON
                nid.hIcon = m_Icon
            End If
            If m_ToolTip <> "" Then
                nid.uFlags = nid.uFlags + NIF_TIP
                nid.szTip = m_ToolTip & vbNullChar
            End If
            nid.uCallBackmessage = WM_MOUSEMOVE
            Shell_NotifyIcon NIM_ADD, nid
        End If
    Else
        Shell_NotifyIcon NIM_DELETE, nid
    End If
    PropertyChanged "Visible"
    
End Property