1个回答
展开全部
'这是个Test,希望对你有帮助
'类模块
Option Explicit
'************************
'**模块名:cTray **
'**说 明:设置托盘图标**
'************************
Private Const WM_MOUSEFIRST = &H200
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSELAST = &H209
Private Const WM_USER = &H400
Private Const TRAY_CALLBACK = (WM_USER + 1001&)
Private Const PM_REMOVE = &H1
Private Const PM_NOREMOVE = &H0
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_MESSAGE = &H1
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NOTIFYICON_VERSION = 3 'XP类型托盘
Private Const NOTIFYICON_OLDVERSION = 0 '95类型托盘
Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2
'Private Const NIIF_NONE = &H0
'Private Const NIIF_WARNING = &H2
'Private Const NIIF_ERROR = &H3
'Private Const NIIF_INFO = &H1
'Private Const NIIF_GUID = &H4
Public Enum NIIFENUM
NIIF_NONE = &H0
NIIF_WARNING = &H2
NIIF_ERROR = &H3
NIIF_INFO = &H1
NIIF_GUID = &H4
End Enum
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
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Event MouseClick(ByVal Button As Long, ByVal DBClick As Boolean)
Public Event TrayMsgBoxClick(ByVal CloseClick As Boolean)
Dim TheData As NOTIFYICONDATA
Dim WithEvents cPic As PictureBox
Dim TrayIco As StdPicture
Dim TrayTip As String
Public Sub DelTrayIcon()
'删除托盘图标
With TheData
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
DoEvents
End Sub
Public Sub AddTrayIcon(EventPic As PictureBox)
'添加托盘图标
On Error Resume Next
Set cPic = EventPic
With TheData
.uID = vbNull
.hWnd = cPic.hWnd
.cbSize = Len(TheData)
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE
.uCallbackMessage = WM_MOUSEMOVE
.dwState = 0
.dwStateMask = 0
End With
Shell_NotifyIcon NIM_ADD, TheData
End Sub
Public Sub SetTrayTip(Tip As String)
'设置提示消息
With TheData
.szTip = Tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Sub SetTrayIcon(Pic As StdPicture)
'设置托盘图标
If Pic.Type <> vbPicTypeIcon Then Exit Sub
Set TrayIco = Pic
With TheData
.hIcon = TrayIco.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Function SetTrayMsgbox(ByVal MsgInfo As String, Optional ByVal MsgFlags As NIIFENUM, Optional MsgTitle As String = "", Optional MsgTimeout As Long = 2000)
'设置托盘气泡提示对话框
With TheData
.cbSize = Len(TheData)
.hWnd = cPic.hWnd
.uID = vbNull
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = TrayIco.Handle
.szTip = TrayTip & vbNullChar
.dwState = 0
.dwStateMask = 0
.szInfo = MsgInfo & Chr(0)
.szInfoTitle = MsgTitle & Chr(0)
.dwInfoFlags = IIf(MsgTitle = "", NIIF_NONE, MsgFlags)
.uTimeout = MsgTimeout
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Function
Private Sub cPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = X / Screen.TwipsPerPixelX
Select Case X
Case WM_LBUTTONUP
RaiseEvent MouseClick(vbLeftButton, False)
Case WM_LBUTTONDBLCLK
RaiseEvent MouseClick(vbLeftButton, True)
Case WM_RBUTTONUP
RaiseEvent MouseClick(vbRightButton, False)
Case WM_RBUTTONDBLCLK
RaiseEvent MouseClick(vbRightButton, True)
Case WM_MBUTTONUP
RaiseEvent MouseClick(vbMiddleButton, False)
Case WM_MBUTTONDBLCLK
RaiseEvent MouseClick(vbMiddleButton, True)
Case 1028
RaiseEvent TrayMsgBoxClick(True)
Case 1029
RaiseEvent TrayMsgBoxClick(False)
End Select
End Sub
'窗体文件,注意:按钮挡住了一个Picture1
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 165
ClientTop = 735
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Cmd1
Height = 375
Left = 360
TabIndex = 1
Top = 120
Width = 495
End
Begin VB.PictureBox Pic1
Height = 375
Left = 360
ScaleHeight = 315
ScaleWidth = 435
TabIndex = 0
Top = 120
Width = 495
End
Begin VB.Menu mPop
Caption = "菜单"
Begin VB.Menu mPops
Caption = "显示/隐藏"
Index = 0
End
Begin VB.Menu mPops
Caption = "-"
Index = 1
End
Begin VB.Menu mPops
Caption = "关于"
Index = 2
End
Begin VB.Menu mPops
Caption = "退出"
Index = 3
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim WithEvents mcTray As cTray
Attribute mcTray.VB_VarHelpID = -1
Private Sub Form_Load()
Set mcTray = New cTray
With mcTray
.AddTrayIcon Pic1
.SetTrayIcon Me.Icon
.SetTrayTip Me.Caption
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
mcTray.DelTrayIcon
Set mcTray = Nothing
End Sub
Private Sub mcTray_MouseClick(ByVal Button As Long, ByVal DBClick As Boolean)
Select Case Button
Case vbLeftButton
If DBClick = True Then Call ShowHideMe
Debug.Print "左键" & IIf(DBClick = True, "双击", "单击")
Case vbRightButton
If DBClick = True Then PopupMenu mPop
Debug.Print "右键" & IIf(DBClick = True, "双击", "单击")
Case vbMiddleButton
Debug.Print "中键" & IIf(DBClick = True, "双击", "单击")
End Select
End Sub
Private Sub mPops_Click(Index As Integer)
Select Case Index
Case 0
Call ShowHideMe
Case 2
MsgBox "托盘图标例子" & vbCrLf & vbCrLf & "By test"
Case 3
Unload Me
End Select
End Sub
Private Sub Cmd1_Click()
Dim i As Long, j As String
For i = 1 To 5
j = j & vbCrLf
Next i
mcTray.SetTrayMsgbox Space(1) & "测试气泡提示框" & j & Space(1) & "嘿嘿" & j & "By test", NIIF_INFO, "提示"
End Sub
Private Function ShowHideMe()
If Me.WindowState = vbNormal Then
Me.WindowState = vbMinimized
Me.Hide
Else
Me.WindowState = vbNormal
Me.Show
End If
End Function
Private Sub mcTray_TrayMsgBoxClick(ByVal CloseClick As Boolean)
If CloseClick = True Then
Debug.Print "点击关闭按钮"
Else
Debug.Print "点击气泡窗体"
End If
End Sub
'类模块
Option Explicit
'************************
'**模块名:cTray **
'**说 明:设置托盘图标**
'************************
Private Const WM_MOUSEFIRST = &H200
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MOUSELAST = &H209
Private Const WM_USER = &H400
Private Const TRAY_CALLBACK = (WM_USER + 1001&)
Private Const PM_REMOVE = &H1
Private Const PM_NOREMOVE = &H0
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_MESSAGE = &H1
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NOTIFYICON_VERSION = 3 'XP类型托盘
Private Const NOTIFYICON_OLDVERSION = 0 '95类型托盘
Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2
'Private Const NIIF_NONE = &H0
'Private Const NIIF_WARNING = &H2
'Private Const NIIF_ERROR = &H3
'Private Const NIIF_INFO = &H1
'Private Const NIIF_GUID = &H4
Public Enum NIIFENUM
NIIF_NONE = &H0
NIIF_WARNING = &H2
NIIF_ERROR = &H3
NIIF_INFO = &H1
NIIF_GUID = &H4
End Enum
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
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Event MouseClick(ByVal Button As Long, ByVal DBClick As Boolean)
Public Event TrayMsgBoxClick(ByVal CloseClick As Boolean)
Dim TheData As NOTIFYICONDATA
Dim WithEvents cPic As PictureBox
Dim TrayIco As StdPicture
Dim TrayTip As String
Public Sub DelTrayIcon()
'删除托盘图标
With TheData
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
DoEvents
End Sub
Public Sub AddTrayIcon(EventPic As PictureBox)
'添加托盘图标
On Error Resume Next
Set cPic = EventPic
With TheData
.uID = vbNull
.hWnd = cPic.hWnd
.cbSize = Len(TheData)
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE
.uCallbackMessage = WM_MOUSEMOVE
.dwState = 0
.dwStateMask = 0
End With
Shell_NotifyIcon NIM_ADD, TheData
End Sub
Public Sub SetTrayTip(Tip As String)
'设置提示消息
With TheData
.szTip = Tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Sub SetTrayIcon(Pic As StdPicture)
'设置托盘图标
If Pic.Type <> vbPicTypeIcon Then Exit Sub
Set TrayIco = Pic
With TheData
.hIcon = TrayIco.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Function SetTrayMsgbox(ByVal MsgInfo As String, Optional ByVal MsgFlags As NIIFENUM, Optional MsgTitle As String = "", Optional MsgTimeout As Long = 2000)
'设置托盘气泡提示对话框
With TheData
.cbSize = Len(TheData)
.hWnd = cPic.hWnd
.uID = vbNull
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = TrayIco.Handle
.szTip = TrayTip & vbNullChar
.dwState = 0
.dwStateMask = 0
.szInfo = MsgInfo & Chr(0)
.szInfoTitle = MsgTitle & Chr(0)
.dwInfoFlags = IIf(MsgTitle = "", NIIF_NONE, MsgFlags)
.uTimeout = MsgTimeout
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Function
Private Sub cPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = X / Screen.TwipsPerPixelX
Select Case X
Case WM_LBUTTONUP
RaiseEvent MouseClick(vbLeftButton, False)
Case WM_LBUTTONDBLCLK
RaiseEvent MouseClick(vbLeftButton, True)
Case WM_RBUTTONUP
RaiseEvent MouseClick(vbRightButton, False)
Case WM_RBUTTONDBLCLK
RaiseEvent MouseClick(vbRightButton, True)
Case WM_MBUTTONUP
RaiseEvent MouseClick(vbMiddleButton, False)
Case WM_MBUTTONDBLCLK
RaiseEvent MouseClick(vbMiddleButton, True)
Case 1028
RaiseEvent TrayMsgBoxClick(True)
Case 1029
RaiseEvent TrayMsgBoxClick(False)
End Select
End Sub
'窗体文件,注意:按钮挡住了一个Picture1
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 165
ClientTop = 735
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Cmd1
Height = 375
Left = 360
TabIndex = 1
Top = 120
Width = 495
End
Begin VB.PictureBox Pic1
Height = 375
Left = 360
ScaleHeight = 315
ScaleWidth = 435
TabIndex = 0
Top = 120
Width = 495
End
Begin VB.Menu mPop
Caption = "菜单"
Begin VB.Menu mPops
Caption = "显示/隐藏"
Index = 0
End
Begin VB.Menu mPops
Caption = "-"
Index = 1
End
Begin VB.Menu mPops
Caption = "关于"
Index = 2
End
Begin VB.Menu mPops
Caption = "退出"
Index = 3
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim WithEvents mcTray As cTray
Attribute mcTray.VB_VarHelpID = -1
Private Sub Form_Load()
Set mcTray = New cTray
With mcTray
.AddTrayIcon Pic1
.SetTrayIcon Me.Icon
.SetTrayTip Me.Caption
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
mcTray.DelTrayIcon
Set mcTray = Nothing
End Sub
Private Sub mcTray_MouseClick(ByVal Button As Long, ByVal DBClick As Boolean)
Select Case Button
Case vbLeftButton
If DBClick = True Then Call ShowHideMe
Debug.Print "左键" & IIf(DBClick = True, "双击", "单击")
Case vbRightButton
If DBClick = True Then PopupMenu mPop
Debug.Print "右键" & IIf(DBClick = True, "双击", "单击")
Case vbMiddleButton
Debug.Print "中键" & IIf(DBClick = True, "双击", "单击")
End Select
End Sub
Private Sub mPops_Click(Index As Integer)
Select Case Index
Case 0
Call ShowHideMe
Case 2
MsgBox "托盘图标例子" & vbCrLf & vbCrLf & "By test"
Case 3
Unload Me
End Select
End Sub
Private Sub Cmd1_Click()
Dim i As Long, j As String
For i = 1 To 5
j = j & vbCrLf
Next i
mcTray.SetTrayMsgbox Space(1) & "测试气泡提示框" & j & Space(1) & "嘿嘿" & j & "By test", NIIF_INFO, "提示"
End Sub
Private Function ShowHideMe()
If Me.WindowState = vbNormal Then
Me.WindowState = vbMinimized
Me.Hide
Else
Me.WindowState = vbNormal
Me.Show
End If
End Function
Private Sub mcTray_TrayMsgBoxClick(ByVal CloseClick As Boolean)
If CloseClick = True Then
Debug.Print "点击关闭按钮"
Else
Debug.Print "点击气泡窗体"
End If
End Sub
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询