1
0
mirror of https://e.coding.net/circlecloud/VBFunctionBas.git synced 2024-10-31 22:38:50 +00:00
VBFunctionBas/Tray_Tools.bas
2017-02-13 00:36:10 +08:00

234 lines
11 KiB
QBasic
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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
''**************************************************************************
''*******窗口过程拦截*******************************************************
''**************************************************************************