VB程序启动后如何在通知区域显示

'语言:Micrisift Visual Basic 6.0
'功能:向系统托盘区添加图标
'作者:黄旭东
'日期:2004-10-22
'版权:CopyRight 2001-2005 By Faib Studio
'网址:http://faib.yeah.net
'邮件:faib920@163.com

Option Explicit

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Const GWL_WNDPROC = (-4)
Private Const GWL_USERDATA = (-21)
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 NIF_INFO = &H10
Private Const NIIF_NONE = &H0
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_INFO = &H1

Private Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uId As Long
    uFlags As Long
    uCallBackMessage As Long
    hIcon As Long
    szTip As String * 128
    dwState As Long
    dwStateMask As Long
    szInfo As String * 256
    uTimeoutOrVersion As Long
    szInfoTitle As String * 64
    dwInfoFlags As Long
End Type

Public Enum EnumTrayEvent
    fbmNone = &H0
    fbmOnLButtonUp = &H1
    fbmOnRButtonUp = &H2
    fbmOnMButtonUp = &H4
    fbmOnLButtonDown = &H8
    fbmOnRButtonDown = &H10
    fbmOnMButtonDown = &H20
    fbmOnLButtonDbClick = &H40
    fbmOnRButtonDbClick = &H80
    fbmOnMButtonDbClick = &H100
    fbmOnAllClickEvents = &H1FF
End Enum
Public Enum EnumTrayMessage
    fbmMouseMove = &H200
    fbmLButtonDown = &H201
    fbmLButtonUp = &H202
    fbmLButtonDbClick = &H203
    fbmRButtonDown = &H204
    fbmRButtonUp = &H205
    fbmRButtonDbClick = &H206
    fbmMButtonDown = &H207
    fbmMButtonUp = &H208
    fbmMButtonDbClick = &H209
End Enum
Enum EnumTitleIcon
   fbiNone = 0
   fbiInfo = 1
   fbiWarning = 2
   fbiError = 3
End Enum

Dim sIcon As StdPicture
Dim sVis As Boolean
Dim sForm As Form
Dim sMenu As Menu
Dim shWnd As Long
Dim sTip As String
Dim sStyle As EnumTrayEvent
Dim nTray As NOTIFYICONDATA
Dim proWnd As Long
Dim mHook As Long
Dim mVis As Boolean

Public Property Let HookAddress(ByVal NewVal As Long)
'hook地址
    mHook = NewVal
End Property

Public Property Get PopupStyle() As EnumTrayEvent
'返回/设置托盘菜单的动作模式
    PopupStyle = sStyle
End Property

Public Property Let PopupStyle(NewVal As EnumTrayEvent)
    sStyle = NewVal
End Property

Public Property Get Icon() As StdPicture
'图标
    Set Icon = sIcon
End Property

Public Property Set Icon(NewVal As StdPicture)
    If sIcon Is Nothing Then
        Set sIcon = NewVal
    Else
        If Not NewVal Is sIcon Then Set sIcon = NewVal
    End If
    If Not sVis Then Exit Property '如果没有显示则退出,否则修改图标
    Modify "Icon"
End Property

Public Property Get TrayForm() As Form
'主窗体
    Set TrayForm = sForm
End Property

Public Property Set TrayForm(NewVal As Form)
    If sForm Is Nothing Then
        Set sForm = NewVal
    Else
        If Not NewVal Is sForm Then Set sForm = NewVal
    End If
End Property

Public Property Get PopupMenu() As Menu
'弹出菜单
    Set PopupMenu = sMenu
End Property

Public Property Set PopupMenu(NewVal As Menu)
    If sMenu Is Nothing Then
        Set sMenu = NewVal
    Else
        If Not sMenu Is sMenu Then Set sMenu = NewVal
    End If
End Property

Public Property Get TipText() As String
'提示信息
    TipText = sTip
End Property

Public Property Let TipText(NewVal As String)
    sTip = NewVal
    If Not sVis Then Exit Property '如果没有显示则退出,否则修改提示信息
    Modify "Tip"
End Property

Public Property Get Visible() As Boolean
'是否显示
    Visible = sVis
End Property

Public Property Let Visible(NewVal As Boolean)
    If NewVal = sVis Then Exit Property '如果设置相同则退出
    sVis = NewVal
    If NewVal Then Show Else Hide
End Property

Public Sub Show() '显示
    If mVis Then Exit Sub
    With nTray
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .cbSize = Len(nTray)
        .hWnd = sForm.hWnd
        .uId = vbNull
        .uCallBackMessage = fbmMouseMove
        .hIcon = sIcon.Handle
        .szTip = sTip & vbNullChar
    End With
    Shell_NotifyIcon NIM_ADD, nTray
    proWnd = SetWindowLong(sForm.hWnd, GWL_WNDPROC, AddressOf Wndproc)
    mVis = True: sVis = True
End Sub

Public Sub Hide() '移除
    If Not mVis Then Exit Sub
    SetWindowLong sForm.hWnd, GWL_WNDPROC, proWnd
    Shell_NotifyIcon NIM_DELETE, nTray
    mVis = False: sVis = False
End Sub

Public Sub ShowMessage(Title As String, Message As String, Optional TitleIcon As EnumTitleIcon = 0, Optional TimeOut As Long = 500)
    If Not sVis Then Exit Sub
    With nTray
        .uFlags = NIF_INFO Or NIF_MESSAGE
        .dwInfoFlags = NIIF_INFO
        .dwState = 0
        .hIcon = TitleIcon
        .dwStateMask = 0
        .szInfo = Message & vbNullChar
        .uTimeoutOrVersion = TimeOut
        .szInfoTitle = Title & vbNullChar
    End With
    Shell_NotifyIcon NIM_MODIFY, nTray
End Sub

Private Function Wndproc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    If Msg = fbmMouseMove Then
        Select Case lParam
        Case &H2
            Call Hide: Set sForm = Nothing: Set sIcon = Nothing
        Case fbmLButtonDbClick
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnLButtonDbClick) Then Popup
        Case fbmLButtonDown
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnLButtonDown) Then Popup
        Case fbmLButtonUp
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnLButtonUp) Then Popup
        Case fbmMButtonDbClick
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnMButtonDbClick) Then Popup
        Case fbmMButtonDown
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnMButtonDown) Then Popup
        Case fbmMButtonUp
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnMButtonUp) Then Popup
        Case fbmRButtonDbClick
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnRButtonDbClick) Then Popup
        Case fbmRButtonDown
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnRButtonDown) Then Popup
        Case fbmRButtonUp
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
            If sStyle <> fbmNone Then If CBool(sStyle And fbmOnRButtonUp) Then Popup
        Case fbmMouseMove
            If mHook <> 0 Then Wndproc = CallWindowProc(mHook, hWnd, lParam, wParam, lParam)
        End Select
    End If
    Wndproc = CallWindowProc(proWnd, hWnd, Msg, wParam, lParam)
End Function

Private Sub Modify(s As String)
    With nTray
        Select Case s
        Case "Icon"
            .hIcon = sIcon.Handle
            .uFlags = NIF_ICON
        Case "Tip"
            .uFlags = NIF_TIP
            .szTip = sTip & vbNullChar
        End Select
    End With
    Shell_NotifyIcon NIM_MODIFY, nTray
End Sub

Private Sub Popup()
'弹出菜单
    SetForegroundWindow sForm.hWnd
    sForm.PopupMenu sMenu
End Sub