mirror of
https://e.coding.net/circlecloud/VBFunctionBas.git
synced 2024-10-31 22:38:50 +00:00
234 lines
11 KiB
QBasic
234 lines
11 KiB
QBasic
Attribute VB_Name = "Tray_Tools"
|
||
'#######################################模块说明#########################################
|
||
|
||
'名称:托盘工具
|
||
|
||
'功能:实现VB托盘和托盘气泡添加,修改,删除等功能
|
||
|
||
'最后更新日期:2014年7月10日
|
||
|
||
'创建人:蒋天蓓
|
||
|
||
'单位:上海市定海水电工程安装有限公司
|
||
|
||
''====================================模块使用说明=======================================
|
||
'****************************************************
|
||
'添加托盘:Tray_Add (窗体句柄 As Long, 图标句柄 As Long, 提示语 As String), _
|
||
[气泡开关 As Boolean = False(默认关)](可选), _
|
||
[气泡标题 As String](可选), _
|
||
[气泡内容 As String](可选), _
|
||
[气泡图标 As NIIF_InFoType](可选), _
|
||
[气泡显示时间 As Long](可选))
|
||
|
||
'修改托盘:Tray_Change (窗体句柄 As Long, 图标句柄 As Long, 提示语 As String), _
|
||
[气泡开关 As Boolean = False(默认关)](可选), _
|
||
[气泡标题 As String](可选), _
|
||
[气泡内容 As String](可选), _
|
||
[气泡图标 As NIIF_InFoType](可选), _
|
||
[气泡显示时间 As Long](可选))
|
||
|
||
'删除托盘:Tray_Del()
|
||
'****************************************************
|
||
'托盘菜单:Tray_Menu (Frm As Form, Button As Integer, Shift As Integer, X As Single, Y As Single)
|
||
'#######################################模块说明#########################################
|
||
Option Explicit
|
||
'''========================托盘图标============================
|
||
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 Shell_NotifyIcon Lib "shell32.dll" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
|
||
Private Declare Function CallWindowProc Lib "user32.dll" 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 Const WM_MOUSEMOVING = &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_SETHOTKEY = &H32 '响应您定义的热键
|
||
Private Const WM_USER = &H400
|
||
Private Const WM_NOTIFYICON = WM_USER + 1 ' 自定义消息
|
||
Private Const GWL_WNDPROC = (-4) ' 关于气球提示的自定义消息, 2000下不产生这些消息
|
||
Private Const NIN_BALLOONSHOW = (WM_USER + &H2) ' 当 Balloon Tips 弹出时执行
|
||
Private Const NIN_BALLOONHIDE = (WM_USER + &H3) ' 当 Balloon Tips 消失时执行(如 SysTrayIcon 被删除),' 但指定的 TimeOut 时间到或鼠标点击 Balloon Tips 后的消失不发送此消息
|
||
Private Const NIN_BALLOONTIMEOUT = (WM_USER + &H4) ' 当 Balloon Tips 的 TimeOut 时间到时执行
|
||
Private Const NIN_BALLOONUSERCLICK = (WM_USER + &H5) ' 当鼠标点击 Balloon Tips 时执行。
|
||
' 注意:在XP下执行时 Balloon Tips 上有个关闭按钮,
|
||
' 如果鼠标点在按钮上将接收到 NIN_BALLOONTIMEOUT 消息。
|
||
Private Type NOTIFYICONDATA
|
||
cbSize As Long ' 结构大小(字节)
|
||
hwnd As Long ' 处理消息的窗口的句柄
|
||
uId As Long ' 唯一的标识符
|
||
uFlags As Long ' Flags
|
||
uCallBackMessage As Long ' 处理消息的窗口接收的消息
|
||
hIcon As Long ' 托盘图标句柄
|
||
szTip As String * 128 ' Tooltip 提示文本
|
||
dwState As Long ' 托盘图标状态
|
||
dwStateMask As Long ' 状态掩码
|
||
szInfo As String * 256 ' 气球提示文本
|
||
uTimeoutOrVersion As Long ' 气球提示消失时间或版本
|
||
' uTimeout - 气球提示消失时间(单位:ms, 10000 -- 30000)
|
||
' uVersion - 版本(0 for V4, 3 for V5)
|
||
szInfoTitle As String * 64 ' 气球提示标题
|
||
dwInfoFlags As Long ' 气球提示图标
|
||
End Type ' dwState to NOTIFYICONDATA structure
|
||
Private Const NIS_HIDDEN = &H1 ' 隐藏图标
|
||
Private Const NIS_SHAREDICON = &H2 ' 共享图标' dwInfoFlags to NOTIFIICONDATA structure
|
||
Public Enum NIIF_InFoType
|
||
NIIF_NONE = &H0 ' 无图标
|
||
NIIF_INFO = &H1 ' "消息"图标
|
||
NIIF_WARNING = &H2 ' "警告"图标
|
||
NIIF_ERROR = &H3 ' "错误"图标
|
||
End Enum ' uFlags to NOTIFYICONDATA structure
|
||
Private Const NIF_MESSAGE As Long = &H1
|
||
Private Const NIF_ICON As Long = &H2
|
||
Private Const NIF_TIP As Long = &H4
|
||
Private Const NIF_STATE As Long = &H8
|
||
Private Const NIF_INFO As Long = &H10 ' dwMessage to Shell_NotifyIcon
|
||
Private Const NIM_ADD As Long = &H0
|
||
Private Const NIM_MODIFY As Long = &H1
|
||
Private Const NIM_DELETE As Long = &H2
|
||
Private Const NIM_SETFOCUS As Long = &H3
|
||
Private Const lngNIM_SETVERSION As Long = &H4
|
||
Private Tray As NOTIFYICONDATA
|
||
Public OldWndProc As Long
|
||
|
||
Private Declare Function RegisterWindowMessage Lib "user32" Alias _
|
||
"RegisterWindowMessageA" (ByVal lpString As String) As Long
|
||
|
||
Private Const RASDIALEVENT = "RasDialEvent"
|
||
Private Const WM_RASDIALEVENT = &HCCCD&
|
||
Public m_RasMessage As Long
|
||
|
||
''''========================托盘图标============================
|
||
Public Sub Tray_Add(ByVal hwnd As Long, ByVal Icon As Long, ByVal Tip As String, _
|
||
Optional ByVal bTipInfo As Boolean = False, _
|
||
Optional ByVal TipInfoTitle As String = vbNullString, _
|
||
Optional ByVal TipInfo As String = vbNullString, _
|
||
Optional ByVal TipInfoType As NIIF_InFoType = NIIF_INFO, _
|
||
Optional ByVal TipInfoDaily As Long = 1000)
|
||
With Tray
|
||
.cbSize = Len(Tray)
|
||
.uId = 0
|
||
.hwnd = hwnd '托盘句柄
|
||
.hIcon = Icon
|
||
.szTip = Tip & vbNullChar '鼠标移动到托盘时显示内容
|
||
.uFlags = NIF_TIP Or NIF_MESSAGE Or NIF_ICON
|
||
.uCallBackMessage = WM_NOTIFYICON
|
||
.dwState = 0
|
||
.dwStateMask = 0
|
||
If bTipInfo Then .uFlags = .uFlags Or NIF_INFO Or NIF_STATE
|
||
.szInfoTitle = TipInfoTitle & vbNullChar '气泡标题
|
||
.szInfo = TipInfo & vbNullChar '气泡内容
|
||
.dwInfoFlags = TipInfoType '气泡图标
|
||
.uTimeoutOrVersion = TipInfoDaily '气泡延时时间
|
||
End With
|
||
If OldWndProc = 0 Then
|
||
OldWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf TrayWndProc)
|
||
Shell_NotifyIcon NIM_ADD, Tray
|
||
Else
|
||
Shell_NotifyIcon NIM_MODIFY, Tray
|
||
End If
|
||
End Sub
|
||
|
||
Public Sub Tray_Change(ByVal hwnd As Long, _
|
||
Optional ByVal Icon As Long = 0, _
|
||
Optional ByVal Tip As String = "", _
|
||
Optional ByVal bTipInfo As Boolean = False, _
|
||
Optional ByVal TipInfoTitle As String = vbNullChar, _
|
||
Optional ByVal TipInfo As String = vbNullChar, _
|
||
Optional ByVal TipInfoType As NIIF_InFoType = NIIF_NONE, _
|
||
Optional ByVal TipInfoDaily As Long = 0)
|
||
With Tray
|
||
If Icon <> 0 Then .hIcon = Icon
|
||
If Tip <> "" Then .szTip = Tip & vbNullChar: .uFlags = NIF_TIP Or NIF_MESSAGE Or NIF_ICON
|
||
If bTipInfo Then .uFlags = .uFlags Or NIF_INFO Or NIF_STATE
|
||
.szInfoTitle = TipInfoTitle & vbNullChar
|
||
.szInfo = TipInfo & vbNullChar
|
||
.dwInfoFlags = TipInfoType
|
||
.uTimeoutOrVersion = TipInfoDaily
|
||
End With
|
||
Shell_NotifyIcon NIM_MODIFY, Tray
|
||
End Sub
|
||
|
||
|
||
Public Sub Tray_Del()
|
||
If OldWndProc <> 0 Then SetWindowLong Tray.hwnd, GWL_WNDPROC, OldWndProc
|
||
OldWndProc = 0
|
||
Shell_NotifyIcon NIM_DELETE, Tray
|
||
End Sub
|
||
|
||
''**************************************************************************
|
||
''*******窗口过程拦截函数'OldWndProc = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf TrayWndProc)
|
||
''**************************************************************************
|
||
'Private Declare Function CallWindowProc Lib "user32.dll" 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 Const WM_MOUSEMOVING = &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_SETHOTKEY = &H32 '响应您定义的热键
|
||
'Private Const WM_USER = &H400
|
||
'Private Const WM_NOTIFYICON = WM_USER + 1 ' 自定义消息
|
||
'Private Const GWL_WNDPROC = (-4) ' 关于气球提示的自定义消息, 2000下不产生这些消息
|
||
'Private Const NIN_BALLOONSHOW = (WM_USER + &H2) ' 当 Balloon Tips 弹出时执行
|
||
'Private Const NIN_BALLOONHIDE = (WM_USER + &H3) ' 当 Balloon Tips 消失时执行(如 SysTrayIcon 被删除),' 但指定的 TimeOut 时间到或鼠标点击 Balloon Tips 后的消失不发送此消息
|
||
'Private Const NIN_BALLOONTIMEOUT = (WM_USER + &H4) ' 当 Balloon Tips 的 TimeOut 时间到时执行
|
||
'Private Const NIN_BALLOONUSERCLICK = (WM_USER + &H5) ' 当鼠标点击 Balloon Tips 时执行。
|
||
''*******窗口过程拦截*********************************************************
|
||
'Public Function TrayWndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
|
||
' ' 拦截 WM_NOTIFYICON 消息
|
||
' If Msg = WM_NOTIFYICON Then
|
||
' Select Case lParam
|
||
'
|
||
' Case WM_LBUTTONUP
|
||
' Debug.Print "左键单击"
|
||
'
|
||
' Case WM_LBUTTONDBLCLK
|
||
' Debug.Print "左键双击"
|
||
'
|
||
' Case WM_RBUTTONUP
|
||
' Debug.Print "右键单击"
|
||
'
|
||
' Case WM_RBUTTONDBLCLK
|
||
' Debug.Print "右键双击"
|
||
'
|
||
' Case WM_MBUTTONUP
|
||
' Debug.Print "中键单击"
|
||
'
|
||
' Case WM_MBUTTONDBLCLK
|
||
' Debug.Print "中键双击"
|
||
'
|
||
' Case NIN_BALLOONSHOW
|
||
' Debug.Print "显示气球提示"
|
||
'
|
||
' Case NIN_BALLOONHIDE
|
||
' Debug.Print "删除托盘图标"
|
||
'
|
||
' Case NIN_BALLOONTIMEOUT
|
||
' Debug.Print "气球提示消失"
|
||
'
|
||
' Case NIN_BALLOONUSERCLICK
|
||
' Debug.Print "单击气球提示"
|
||
'
|
||
' Case WM_MOUSEMOVING
|
||
' Debug.Print "鼠标移动"
|
||
'
|
||
' Case Else
|
||
' Debug.Print lParam
|
||
'
|
||
' End Select
|
||
' End If
|
||
' TrayWndProc = CallWindowProc(OldWndProc, hWnd, Msg, wParam, lParam)'将消息发回原来的窗体
|
||
'End Function
|
||
''**************************************************************************
|
||
''*******窗口过程拦截*******************************************************
|
||
''**************************************************************************
|
||
|