我做桌面托盘隐藏时翻译了一篇文章是关于托盘。现在公开我这个翻译。
三个文件，一个是FORM1，modIconToPic、modMain。
'************************modMain***********************************
'**模 块 名：获取托盘图标
'**说 明：By:小江翻译（http://www.codeproject.com/KB/applications/ShellTrayInfo.aspx）
'**日 期：2008-12-10 00:27:01
'*************************************************************************
Option Explicit
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'加入托盘
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Const NIM_ADD = &H0 '表示要往任务栏中加入图标
Public Const NIM_DELETE = &H2 '删除图标
Public Const NIM_MODIFY = &H1 '修改图标
Public Const NIF_ICON = &H2 '允许图标显示
Public Const NIF_MESSAGE = &H1 '允许图标消息转发
Public Const NIF_TIP = &H4 '允许图标显示图标提示字符串
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + 1 ' 自定义消息，用于子类化时，取得托盘相应信息
'托盘BOTTON
Public Const TBSTATE_HIDDEN = &H8
Public Const WM_SIZE = &H5
'Public Const WM_USER As Long = &H400
Public Const TB_BUTTONCOUNT As Long = (WM_USER + 24)
Public Const TB_HIDEBUTTON As Long = (WM_USER + 4)
Public Const TB_GETBUTTON As Long = (WM_USER + 23)
Public Const TB_GETBITMAP As Long = (WM_USER + 44)
Public Const TB_DELETEBUTTON As Long = (WM_USER + 22)
Public Const TB_ADDBUTTONS As Long = (WM_USER + 20)
Public Const TB_INSERTBUTTON As Long = (WM_USER + 21)
Public Const TB_GETBUTTONTEXTA As Long = (WM_USER + 45)
Public Const TB_ISBUTTONHIDDEN As Long = (WM_USER + 12)
Public Const TB_MOVEBUTTON = (WM_USER + 82)
Public Const TB_AUTOSIZE As Long = (WM_USER + 33)
Public Const ILD_NORMAL As Long = &H0
'进程读写
Public Const READ_CONTROL As Long = &H20000
Public Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Public Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Public Const STANDARD_RIGHTS_EXECUTE As Long = (READ_CONTROL)
Public Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Public Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Public Const SYNCHRONIZE As Long = &H100000
Public Const PROCESS_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Public Const PROCESS_TERMINATE As Long = (&H1)
'内存读写参数
Public Const PROCESS_VM_OPERATION As Long = (&H8)
Public Const PROCESS_VM_READ As Long = (&H10)
Public Const PROCESS_VM_WRITE As Long = (&H20)
Public Const MEM_RESERVE As Long = &H2000
Public Const MEM_COMMIT As Long = &H1000
Public Const MEM_RELEASE As Long = &H8000
Public Const PAGE_READWRITE As Long = &H4
'窗口状态参数
Public Const SW_HIDE = 0
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const PROCESS_QUERY_INFORMATION = 1024
'托盘
Public Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uid As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
'ICON结构
Public Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
'Botton结构
Public Type TBBUTTON
iBitmap As Long
idCommand As Long
fsState As Byte
fsStyle As Byte
bReserved1 As Byte
bReserved2 As Byte
dwData As Long
iString As Long
End Type
''没有公开的TRAYDATA结构
Public Type TRAYDATA
hWnd As Long
uid As Long
uCallBackMessage As Long
Reserved1(0 To 1) As Long
hIcon As Long
Reserved2(0 To 5) As Integer
ExePath(0 To 255) As Byte
End Type
'自定义结构
Public Type TrayItemInfo
hWnd As Long
uid As Long
hIcon As Long
uCallBackMessage As Long
sTip As String
sProcessPath As String
lIdCommand As Long
bVisible As Boolean
IsSetHide As Boolean
End Type
Public Const MAX_PATH& = 260
Public m_hTrayWnd As Long
Sub Main()
Form1.Show
End Sub
'*************************************************************************
'**函 数 名：得到系统托盘句柄
'*************************************************************************
Public Function FindSysTray() As Long
Dim hTrayWnd As Long
hTrayWnd = FindWindow("Shell_TrayWnd", vbNullString)
If hTrayWnd <> 0 Then
hTrayWnd = FindWindowEx(hTrayWnd, 0, "TrayNotifyWnd", vbNullString)
hTrayWnd = FindWindowEx(hTrayWnd, 0, "SysPager", vbNullString)
If hTrayWnd <> 0 Then
hTrayWnd = FindWindowEx(hTrayWnd, 0, "ToolbarWindow32", vbNullString)
End If
End If
FindSysTray = hTrayWnd
End Function
'*************************************************************************
'**函 数 名：转换BYTE数组 及 去除最后的"/0"。
'*************************************************************************
Public Function DelEndNull(ByVal sSrc As String) As String
Dim lNullpos As Long
lNullpos = InStr(sSrc, Chr$(0))
If lNullpos > 0 Then
DelEndNull = Left$(sSrc, lNullpos - 1)
Else
DelEndNull = sSrc
End If
End Function
'*************************************************************************
'**函 数 名：'去除路径中的？？问号。
'*************************************************************************
Public Function CheckPath(ByVal sPath As String) As String
On Error Resume Next
sPath = Replace$(sPath, "/??/", "")
If UCase$(Left$(sPath, 12)) = "/SYSTEMROOT/" Then sPath = GetWinDir & Mid$(sPath, 12)
CheckPath = sPath
End Function
'*************************************************************************
'**函 数 名'得到系统路径
'*************************************************************************
Public Function GetWinDir() As String
Dim sTemp As String * 256
Dim iCharLen As Integer
iCharLen = GetWindowsDirectory(sTemp, Len(sTemp))
GetWinDir = Left$(sTemp, iCharLen)
End Function
'------------------------modIconToPic------------------------------------------------
Option Explicit
'网络上抄摘，原作者不详。
'把ICON文件转为一般图像文件与获取EXE文件的图标
'OleCreatePictureIndirect建立一个图像对象,并返回对象句柄
'pDicDesc 图象结构
'riid 接口的标识符
'fown 是否清除图像对象,如设置为真,则图片对象将摧毁它的图片当对象被摧毁时。如果假, 则由用户负责摧毁图片对象。
'lpUnk 输出变量地址接口类型
Public Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Public Type TypeIcon
cbSize As Long '结构大小
picType As PictureTypeConstants '图像类型
hIcon As Long '图标句柄
End Type
'CLSID类标识符的缩写
Public Type CLSID
id(16) As Byte '由16个成员组成的字节数组
End Type
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Type SHFILEINFO
hIcon As Long '文件的图标句柄
iIcon As Long '图标的系统索引号
dwAttributes As Long '文件的属性值
szDisplayName As String * 260 '文件的显示名
szTypeName As String * 80 '文件的类型名
End Type
Public Const SHGFI_ICON = &H100 '获得图标
Public Const SHGFI_LARGEICON = &H0 '获取文件大图标
Public Const SHGFI_SMALLICON = &H1 '获取小图标
'ICON 转 Picture
Public Function IconToPic(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown 'Com接口
With new_icon
.cbSize = Len(new_icon)
.picType = vbPicTypeIcon 'Picture 对象的图标类型
.hIcon = hIcon
End With
With cls_id
.id(8) = &HC0
.id(15) = &H46
End With
hRes = OleCreatePictureIndirect(new_icon, cls_id, 1, lpUnk)
If hRes = 0 Then Set IconToPic = lpUnk
End Function
'获得文件ICON
Public Function GetExeIcon(FileName, Optional ByVal SmallIcon As Boolean = True) As IPictureDisp
Dim Index As Integer
Dim hIcon As Long
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO
If SmallIcon = True Then
SHGetFileInfo FileName, 0, sh_info, Len(sh_info), SHGFI_ICON + SHGFI_SMALLICON
Else
SHGetFileInfo FileName, 0, sh_info, Len(sh_info), SHGFI_ICON + SHGFI_LARGEICON
End If
hIcon = sh_info.hIcon
Set icon_pic = IconToPic(hIcon)
Set GetExeIcon = icon_pic
Set icon_pic = Nothing
End Function
'*************************************************************************
'**函 数 名：通过PID返回程序路径
'*************************************************************************
Public Function GetAppPathByPid(lPid As Long) As String
Dim sRet As String
Dim lret As Long
Dim lModules(1 To MAX_PATH) As Long
Dim sModName As String
Dim lCBSize As Long
Dim hProcess As Long
Dim sProcessPath As String
sProcessPath = "[Unknown Process]"
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, False, lPid)
If hProcess Then
lret = EnumProcessModules(hProcess, lModules(1), MAX_PATH, lCBSize)
If lret <> 0 Then
sModName = Space$(MAX_PATH)
lret = GetModuleFileNameExA(hProcess, lModules(1), sModName, 500) '从句柄的取得对应的程序路径
sProcessPath = Left$(sModName, lret)
sProcessPath = CheckPath(Trim$(sProcessPath)) '去除路径中/??/的内容
End If
End If
GetAppPathByPid = sProcessPath
CloseHandle hProcess
End Function
'-------------------------------form1---------------------------------------
Option Explicit
'*************************************************************************
'**模 块 名：获取托盘图标
'**说 明：By:小江翻译（http://www.codeproject.com/KB/applications/ShellTrayInfo.aspx）
'**日 期：2008-12-10 00:27:01
'*************************************************************************
Private Declare Function GetLastError Lib "kernel32" () As Long
Private m_aTrayinfo() As TrayItemInfo
Private iIndex As Integer
Public Sub Command1_Click()
Dim lTrayPid As Long
Dim lCount As Long
Dim lret As Long
Dim hProcess As Long
Dim lAddress As Long
Dim udtTb As TBBUTTON
Dim udtTray As TRAYDATA
Dim udtTifo As TrayItemInfo
Dim lTextAdr As Long
Dim asTip(0 To 1024) As Byte
Dim sTip As String
Dim icoInfo As ICONINFO
Dim i As Integer
Set ListView1.Icons = Nothing
Set ListView1.SmallIcons = Nothing
ListView1.ListItems.Clear
ImageList1.ListImages.Clear
ImageList1.ImageHeight = 16
ImageList1.ImageWidth = 16
m_hTrayWnd = FindSysTray()
lret = GetWindowThreadProcessId(m_hTrayWnd, lTrayPid)
lCount = SendMessage(m_hTrayWnd, TB_BUTTONCOUNT, 0, ByVal 0&)
hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, lTrayPid)
lAddress = VirtualAllocEx(hProcess, ByVal 0&, ByVal 4096&, MEM_COMMIT, PAGE_READWRITE)
For i = 0 To lCount - 1
lret = SendMessage(m_hTrayWnd, TB_GETBUTTON, ByVal i, ByVal lAddress&)
lret = ReadProcessMemory(hProcess, ByVal lAddress, ByVal VarPtr(udtTb), ByVal Len(udtTb), ByVal 0&)
lret = ReadProcessMemory(hProcess, ByVal udtTb.dwData, ByVal VarPtr(udtTray), ByVal Len(udtTray), ByVal 0&)
udtTifo.sProcessPath = DelEndNull(udtTray.ExePath)
If Not CBool((udtTb.fsState And TBSTATE_HIDDEN)) Then
lret = ReadProcessMemory(hProcess, ByVal udtTb.iString, ByVal VarPtr(asTip(0)), ByVal 1024, ByVal 0&)
sTip = DelEndNull(asTip)
Else
sTip = "[Hidden Icon]"
End If
With udtTifo
.sTip = sTip
.hWnd = udtTray.hWnd
.uCallBackMessage = udtTray.uCallBackMessage
.uid = udtTray.uid
.bVisible = Not CBool((udtTb.fsState And TBSTATE_HIDDEN))
.hIcon = udtTray.hIcon
End With
If GetIconInfo(udtTray.hIcon, icoInfo) <> 0 Then
ImageList1.ListImages.Add , , IconToPic(udtTray.hIcon)
'Debug.Print GetLastError
Else
ImageList1.ListImages.Add , , GetExeIcon(udtTifo.sProcessPath)
End If
Debug.Print sTip, GetLastError, i
If ImageList1.ListImages.Count = 1 Then
Set ListView1.Icons = ImageList1
Set ListView1.SmallIcons = ImageList1
End If
ReDim Preserve m_aTrayinfo(0 To i)
m_aTrayinfo(i) = udtTifo
ListView1.ListItems.Add i + 1, , udtTifo.sTip, 1, i + 1
ListView1.ListItems(i + 1).SubItems(1) = udtTifo.sProcessPath
Next
End Sub
Public Sub Command2_Click()
Dim s As String
iIndex = ListView1.SelectedItem.Index - 1
s = ListView1.SelectedItem.Text
Debug.Print s
If iIndex > 0 And s <> "[Hidden Icon]" Then
Call SendMessage(m_hTrayWnd, TB_MOVEBUTTON, iIndex, ByVal CLng(iIndex - 1))
Call Command1_Click
ListView1.SelectedItem = ListView1.ListItems(iIndex)
ListView1.SelectedItem.EnsureVisible
ListView1.SetFocus
End If
End Sub
Public Sub Command3_Click()
Dim s As String
iIndex = ListView1.SelectedItem.Index - 1
s = ListView1.SelectedItem.Text
Debug.Print s
If iIndex < ListView1.ListItems.Count - 1 And s <> "[Hidden Icon]" Then
Call SendMessage(m_hTrayWnd, TB_MOVEBUTTON, iIndex, ByVal CLng(iIndex + 1))
Call Command1_Click
ListView1.SelectedItem = ListView1.ListItems(iIndex + 2)
ListView1.SelectedItem.EnsureVisible
ListView1.SetFocus
End If
End Sub
Private Sub Command4_Click()
iIndex = ListView1.SelectedItem.Index - 1
Const WM_RBUTTONDOWN = &H204
Const WM_RBUTTONUP = &H205
Call PostMessage(m_aTrayinfo(iIndex).hWnd, m_aTrayinfo(iIndex).uCallBackMessage, m_aTrayinfo(iIndex).uid, WM_RBUTTONDOWN)
Call PostMessage(m_aTrayinfo(iIndex).hWnd, m_aTrayinfo(iIndex).uCallBackMessage, m_aTrayinfo(iIndex).uid, WM_RBUTTONUP)
End Sub
Private Sub Command5_Click()
Dim udtIconData As NOTIFYICONDATA
iIndex = ListView1.SelectedItem.Index - 1
If m_aTrayinfo(iIndex).bVisible Then
With udtIconData
.cbSize = Len(udtIconData)
.hIcon = m_aTrayinfo(iIndex).hIcon
.hWnd = m_aTrayinfo(iIndex).hWnd
.szTip = m_aTrayinfo(iIndex).sTip
.uCallBackMessage = m_aTrayinfo(iIndex).uCallBackMessage
'*注：这要hIcon、szTip、uCallBackMessage对应相对应的值。这里我默认三者都有！
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uid = m_aTrayinfo(iIndex).uid
End With
If m_aTrayinfo(iIndex).IsSetHide Then
m_aTrayinfo(iIndex).IsSetHide = False
Call Shell_NotifyIcon(NIM_ADD, udtIconData)
Command5.Caption = "HIDE"
Else
m_aTrayinfo(iIndex).IsSetHide = True
Call Shell_NotifyIcon(NIM_DELETE, udtIconData)
Command5.Caption = "SHOW"
End If
End If
End Sub
Private Sub Form_Load()
Call Command1_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim iIndex As Integer
Dim udtIconData As NOTIFYICONDATA
Cancel = 1
For iIndex = 0 To UBound(m_aTrayinfo)
If m_aTrayinfo(iIndex).IsSetHide Then
With udtIconData
.cbSize = Len(udtIconData)
.hIcon = m_aTrayinfo(iIndex).hIcon
.hWnd = m_aTrayinfo(iIndex).hWnd
.szTip = m_aTrayinfo(iIndex).sTip
.uCallBackMessage = m_aTrayinfo(iIndex).uCallBackMessage
'*注：这要hIcon、szTip、uCallBackMessage对应相对应的值。这里我默认三者都有！
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uid = m_aTrayinfo(iIndex).uid
End With
Call Shell_NotifyIcon(NIM_ADD, udtIconData)
End If
Next
Cancel = 0
End Sub
