程序(附后)用到了Shell_NotifyIcon、SendMessage、CallWindowProc、SetWindowLong等API函数,其中Shell_NotifyIcon是主要的函数,它用来添加、删除、更改系统托盘区(taskbar status area)的图标,所以我们先来看看这个函数的声明和参数:
使用API函数之前必须先在程序中声明如下:
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
cbSize As Long 需填入NOTIFYICONDATA数据结构的长度
HWnd As Long 设置成窗口的句柄
Uid As Long 为图标所设置的ID值
UFlags As Long 设置uCallbackMessage,hIcon,szTip是否有效
UCallbackMessage As Long 消息编号
HIcon As Long 显示在状态栏上的图标
SzTip As String * 64 提示信息
End Type
返回值 Long,非零表示成功,零表示失败
在使用这个API函数之前我们应该先定义结构类型NOTIFYICONDATA:
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
然后定义一个NOTIFYICONDATA的变量TheData来记录设置托盘图标的数据
Private TheData As NOTIFYICONDATA
这时我们就可以使用这个函数来设置系统托盘图标了,具体方法如下:
1、添加图标
With TheData
.Uid = 0
.HWnd = frm.HWnd 'frm.HWnd是程序主窗体的句柄
.cbSize = Len(TheData)
.HIcon = frm.Icon.Handle 'frm.Icon.Handle指向主窗体的图标
.UFlags = NIF_ICON
.UCallbackMessage = TRAY_CALLBACK
'作用是允许返回消息,在下一节中会有详细解释。
.UFlags = .UFlags Or NIF_MESSAGE
.cbSize = Len(TheData)
End With
Shell_NotifyIcon NIM_ADD, TheData
'根据前面定义NIM_ADD,设置为“添加模式”,然后添加
2、删去图标
With TheData
.UFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
'根据前面定义NIM_DELETE,设置为“删除模式”
3、更改图标
With TheData
.HIcon = pic.Handle
'pic是图片狂PictureBox,存放图标文件
.UFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
'根据前面定义NIM_MODIFY,设置为“更改模式”
4、为图标添加浮动提示信息
With TheData
.SzTip = tip & vbNullChar
'tip是字符串string,存储提示信息
.UFlags = NIF_TIP
'指明要对浮动提示进行设置
End With
Shell_NotifyIcon NIM_MODIFY, TheData
'根据前面定义NIM_MODIFY,设置为“修改模式”
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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal HWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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 Function NewWindowProc(ByVal HWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'如果用户点击了托盘中的图标,则进行判断是点击了左键还是右键
If Msg = TRAY_CALLBACK Then
'如果点击了左键
If lParam = WM_LBUTTONUP Then
'而这时窗体的状态是最小化时
If TheForm.WindowState = vbMinimized Then _
'恢复到最小化前的窗体状态
TheForm.WindowState = TheForm.LastState
TheForm.SetFocus
Exit Function
End If
End If
'如果点击了右键
If lParam = WM_RBUTTONUP Then
'则弹出右键菜单
TheForm.PopupMenu TheMenu
Exit Function
End If
End If
'如果是其他类型的消息则传递给原有默认的窗口函数
NewWindowProc = CallWindowProc(OldWindowProc, HWnd, Msg, wParam, lParam)
End Function 这样我们就取得并处理了来自托盘图标的消息,现在的问题是在鼠标右键菜单弹出后,怎么控制程序主窗体的状态,这时我们需要用到SendMessage函数来向主窗体发送最大化、最小化、关
'Type NOTIFYICONDATA
' cbSize As Long 需填入NOTIFYICONDATA数据结构的长度
' HWnd As Long 设置成窗口的句柄
' Uid As Long 为图标所设置的ID值
' UFlags As Long 用来设置以下三个参数uCallbackMessage、hIcon、szTip是否有效
' UCallbackMessage As Long 消息编号
' HIcon As Long 显示在状态栏上的图标
' SzTip As String * 64 提示信息
'End Type
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
'记录 设置托盘图标的数据 的数据类型NOTIFYICONDATA
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
'TheData变量记录设置托盘图标的数据
Private TheData As NOTIFYICONDATA
' *********************************************
' 新的窗口过程--主程序中采用SetWindowLong函数改变了窗口函数的地址,消息转向由NewWindowProc处理
' *********************************************
Public Function NewWindowProc(ByVal HWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'如果用户点击了托盘中的图标,则进行判断是点击了左键还是右键
If Msg = TRAY_CALLBACK Then
'如果点击了左键
If lParam = WM_LBUTTONUP Then
'而这时窗体的状态是最小化时
If TheForm.WindowState = vbMinimized Then _
'恢复到最小化前的窗体状态
TheForm.WindowState = TheForm.LastState
TheForm.SetFocus
Exit Function
End If
End If
'如果点击了右键
If lParam = WM_RBUTTONUP Then
'则弹出右键菜单
TheForm.PopupMenu TheMenu
Exit Function
End If
End If'如果是其他类型的消息则传递给原有默认的窗口函数
NewWindowProc = CallWindowProc(OldWindowProc, HWnd, Msg, wParam, lParam)
End Function
' *********************************************
' 把主窗体的图标(Form1.icon属性可改变)添加到托盘中
' *********************************************
Public Sub AddToTray(frm As Form, mnu As Menu)
'知识点滴:HWnd属性
'返回窗体或控件的句柄。语法: object.HWnd
'说明:Microsoft Windows 运行环境,通过给应用程序中的每个窗体和控件
'分配一个句柄(或 hWnd)来标识它们。hWnd 属性用于Windows API调用。
'将主窗体图标添加在托盘中
With TheData
.Uid = 0 '忘了吗?参考一下前面内容,Uid图标的序号,做动画图标有用
.HWnd = frm.HWnd
.cbSize = Len(TheData)
.HIcon = frm.Icon.Handle
.UFlags = NIF_ICON '指明要对图标进行设置
.UCallbackMessage = TRAY_CALLBACK
.UFlags = .UFlags Or NIF_MESSAGE '指明要设置图标或返回信息给主窗体,此句不能省去
.cbSize = Len(TheData) '为什么呢?我们需要在添加图标的同时,让其返回信息
End With '给主窗体,Or的意思是同时进行设置和返回消息
Shell_NotifyIcon NIM_ADD, TheData '根据前面定义NIM_ADD,设置为“添加模式”
End Sub
' *********************************************
' 删除系统托盘中的图标
' *********************************************
Public Sub RemoveFromTray()
'删除托盘中的图标
With TheData
.UFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData '根据前面定义NIM_DELETE,设置为“删除模式”
'恢复原有的设置
SetWindowLong TheForm.HWnd, GWL_WNDPROC, OldWindowProc
End Sub
' *********************************************
' 为托盘中的图标加上浮动提示(也就是鼠标移上去时出现的提示字条)
' *********************************************
Public Sub SetTrayTip(tip As String)
With TheData
.SzTip = tip & vbNullChar
.UFlags = NIF_TIP '指明要对浮动提示进行设置
End With
Shell_NotifyIcon NIM_MODIFY, TheData '根据前面定义NIM_MODIFY,设置为“修改模式”
End Sub
' *********************************************
' 设置托盘的图标(在本例中没有用到,如果要动态改变托盘内显示的图标,它非常有用)
' 例如:1、显示动画图标(方法你一定猜到了,对!使用Timer控件,不断调用此过程,注意把动画放在pic数组中)
' 2、程序处于不同状态时,显示不同的图标,方法是类似的
' 有兴趣的话试一试吧。
' *********************************************
Public Sub SetTrayIcon(pic As Picture)
'判断一下pic中存放的是不是图标
If pic.Type <> vbPicTypeIcon Then Exit Sub
'更换图标为pic中存放的图标
With TheData
.HIcon = pic.Handle
.UFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias " Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
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 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
Private Sub Form_Load()
On Error Resume Next
Dim lb As Long, pa As Long
'map 'user32' into the address space of the calling process.
lb = LoadLibrary("user32")
'retrieve the address of 'SetWindowTextA'
pa = GetProcAddress(lb, "SetWindowTextA")
'Call the SetWindowTextA-function
CallWindowProc pa, Me.hWnd, "Hello !", ByVal 0&, ByVal 0&
'unmap the library's address
FreeLibrary lb
End Sub
GetWindowLong
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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
Const GWL_STYLE = (-16)
Const ES_NUMBER = &H2000&
Public Sub SetNumber(NumberText As TextBox, Flag As Boolean)
Dim curstyle As Long, newstyle As Long
'retrieve the window style
curstyle = GetWindowLong(NumberText.hwnd, GWL_STYLE)
If Flag Then
curstyle = curstyle Or ES_NUMBER
Else
curstyle = curstyle And (Not ES_NUMBER)
End If
'Set the new style
newstyle = SetWindowLong(NumberText.hwnd, GWL_STYLE, curstyle)
'refresh
NumberText.Refresh
End Sub
Private Sub Form_Load()
SetNumber Text1, True
Me.Caption = "Now, try typing some letters into the textbox"
End Sub
Private 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
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Dim TrayI As NOTIFYICONDATA
Private Sub Form_Load()
TrayI.cbSize = Len(TrayI)
'Set the window's handle (this will be used to hook the specified window)
TrayI.hWnd = pichook.hWnd
'Application-defined identifier of the taskbar icon
TrayI.uId = 1&
'Set the flags
TrayI.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
'Set the callback message
TrayI.ucallbackMessage = WM_LBUTTONDOWN
'Set the picture (must be an icon!)
TrayI.hIcon = imgIcon(2).Picture
'Set the tooltiptext
TrayI.szTip = "Recent" & Chr$(0)
'Create the icon
Shell_NotifyIcon NIM_ADD, TrayI
Me.Hide
End Sub
Private Sub Form_Unload(Cancel As Integer)
'remove the icon
TrayI.cbSize = Len(TrayI)
TrayI.hWnd = pichook.hWnd
TrayI.uId = 1&
Shell_NotifyIcon NIM_DELETE, TrayI
End
End Sub
Private Sub mnuPop_Click(Index As Integer)
Select Case Index
Case 0
MsgBox "KPD-Team 1998" + , vbInformation + vbOKOnly
Case 2
Unload Me
End Select
End Sub
Private Sub pichook_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Msg = X / Screen.TwipsPerPixelX
If Msg = WM_LBUTTONDBLCLK Then
'Left button double click
mnuPop_Click 0
ElseIf Msg = WM_RBUTTONUP Then
'Right button click
Me.PopupMenu mnuPopUp
End If
End Sub
Private Sub Timer1_Timer()
Static Tek As Integer
'Animate the icon
Me.Icon = imgIcon(Tek).Picture
TrayI.hIcon = imgIcon(Tek).Picture
Tek = Tek + 1
If Tek = 3 Then Tek = 0
Shell_NotifyIcon NIM_MODIFY, TrayI
End Sub
SendMessage
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Const LB_FINDSTRING = &H18F
Private Sub Form_Load()
With List1
.AddItem "Computer"
.AddItem "Screen"
.AddItem "Modem"
.AddItem "Printer"
.AddItem "Scanner"
.AddItem "Sound Blaster"
.AddItem "Keyboard"
.AddItem "CD-Rom"
.AddItem "Mouse"
End With
End Sub
Private Sub Text1_Change()
'Retrieve the item's listindex
List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text))
End Sub
SetWindowLong
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
'Subclass this form
HookForm Me
'Register this form as a Clipboardviewer
SetClipboardViewer Me.hwnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Unhook the form
UnHookForm Me
End Sub
Private Sub Command1_Click()
'Change the clipboard
Clipboard.Clear
Clipboard.SetText "Hello !"
End Sub
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Public Const WM_DRAWCLIPBOARD = &H308
Public Const GWL_WNDPROC = (-4)
Dim PrevProc As Long
Public Sub HookForm(F As Form)
PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm(F As Form)
SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_DRAWCLIPBOARD Then
MsgBox "Clipboard changed ..."
End If
End Function