'语言: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