'//在窗体中,作个菜单Popup Option Explicit Public LastState As Integer 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 Private Const WM_SYSCOMMAND = &H112 Private Const SC_MOVE = &HF010& Private Const SC_RESTORE = &HF120& Private Const SC_SIZE = &HF000& Private Sub Form_Load() If WindowState = vbMinimized Then LastState = vbNormal Else LastState = WindowState End If AddToTray Me, mnuTray
SetTrayTip "VB Helper tray icon program" End Sub' Enable the correct tray menu items. Private Sub Form_Resize() Select Case WindowState Case vbMinimized mnuTrayMaximize.Enabled = True mnuTrayMinimize.Enabled = False mnuTrayMove.Enabled = False mnuTrayRestore.Enabled = True mnuTraySize.Enabled = False Case vbMaximized mnuTrayMaximize.Enabled = False mnuTrayMinimize.Enabled = True mnuTrayMove.Enabled = False mnuTrayRestore.Enabled = True mnuTraySize.Enabled = False Case vbNormal mnuTrayMaximize.Enabled = True mnuTrayMinimize.Enabled = True mnuTrayMove.Enabled = True mnuTrayRestore.Enabled = False mnuTraySize.Enabled = True End Select If WindowState <> vbMinimized Then _ LastState = WindowState End Sub ' Important! Remove the tray icon. Private Sub Form_Unload(Cancel As Integer) Cancel = 1 Me.WindowState = 1 End Sub Private Sub mnuTrayClose_Click() RemoveFromTray End End Sub Private Sub mnuTrayMaximize_Click() WindowState = vbMaximized End Sub Private Sub mnuTrayMinimize_Click() WindowState = vbMinimized End Sub Private Sub mnuTrayMove_Click() SendMessage hwnd, WM_SYSCOMMAND, _ SC_MOVE, 0& End Sub Private Sub mnuTrayRestore_Click() SendMessage hwnd, WM_SYSCOMMAND, _ SC_RESTORE, 0& End Sub Private Sub mnuTraySize_Click() SendMessage hwnd, WM_SYSCOMMAND, _ SC_SIZE, 0& End Sub'在模块中代码: Option ExplicitPublic OldWindowProc As Long Public TheForm As Form Public TheMenu As MenuDeclare 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 Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPublic 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 = &H2Public 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 TypePrivate TheData As NOTIFYICONDATA ' ********************************************* ' The replacement window proc. ' ********************************************* 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 ' The user clicked on the tray icon. ' Look for click events. If lParam = WM_LBUTTONUP Then ' On left click, show the form. If TheForm.WindowState = vbMinimized Then _ TheForm.WindowState = TheForm.LastState TheForm.SetFocus Exit Function End If If lParam = WM_RBUTTONUP Then ' On right click, show the menu. TheForm.PopupMenu TheMenu Exit Function End If End If
' Send other messages to the original ' window proc. NewWindowProc = CallWindowProc( _ OldWindowProc, hwnd, Msg, _ wParam, lParam) End Function ' ********************************************* ' Add the form's icon to the tray. ' ********************************************* Public Sub AddToTray(frm As Form, mnu As Menu) ' ShowInTaskbar must be set to False at ' design time because it is read-only at ' run time. ' Save the form and menu for later use. Set TheForm = frm Set TheMenu = mnu
' Install the new WindowProc. OldWindowProc = SetWindowLong(frm.hwnd, _ GWL_WNDPROC, AddressOf NewWindowProc)
' Install the form's icon in the tray. With TheData .uID = 0 .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 Shell_NotifyIcon NIM_ADD, TheData End Sub ' ********************************************* ' Remove the icon from the system tray. ' ********************************************* Public Sub RemoveFromTray() ' Remove the icon from the tray. With TheData .uFlags = 0 End With Shell_NotifyIcon NIM_DELETE, TheData
' Restore the original window proc. SetWindowLong TheForm.hwnd, GWL_WNDPROC, _ OldWindowProc End Sub ' ********************************************* ' Set a new tray tip. ' ********************************************* Public Sub SetTrayTip(tip As String) With TheData .szTip = tip & vbNullChar .uFlags = NIF_TIP End With Shell_NotifyIcon NIM_MODIFY, TheData End Sub ' ********************************************* ' Set a new tray icon. ' ********************************************* Public Sub SetTrayIcon(pic As Picture) ' Do nothing if the picture is not an icon. If pic.Type <> vbPicTypeIcon Then Exit Sub ' Update the tray icon. With TheData .hIcon = pic.Handle .uFlags = NIF_ICON End With Shell_NotifyIcon NIM_MODIFY, TheData End Sub
Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
Me.WindowState = 1
End Subcancel为1 即取消UNLOAD事件
Option Explicit
Public LastState As Integer
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
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&
Private Sub Form_Load()
If WindowState = vbMinimized Then
LastState = vbNormal
Else
LastState = WindowState
End If AddToTray Me, mnuTray
SetTrayTip "VB Helper tray icon program"
End Sub' Enable the correct tray menu items.
Private Sub Form_Resize()
Select Case WindowState
Case vbMinimized
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = False
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbMaximized
mnuTrayMaximize.Enabled = False
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbNormal
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = True
mnuTrayRestore.Enabled = False
mnuTraySize.Enabled = True
End Select If WindowState <> vbMinimized Then _
LastState = WindowState
End Sub
' Important! Remove the tray icon.
Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
Me.WindowState = 1
End Sub
Private Sub mnuTrayClose_Click()
RemoveFromTray
End
End Sub
Private Sub mnuTrayMaximize_Click()
WindowState = vbMaximized
End Sub
Private Sub mnuTrayMinimize_Click()
WindowState = vbMinimized
End Sub
Private Sub mnuTrayMove_Click()
SendMessage hwnd, WM_SYSCOMMAND, _
SC_MOVE, 0&
End Sub
Private Sub mnuTrayRestore_Click()
SendMessage hwnd, WM_SYSCOMMAND, _
SC_RESTORE, 0&
End Sub
Private Sub mnuTraySize_Click()
SendMessage hwnd, WM_SYSCOMMAND, _
SC_SIZE, 0&
End Sub'在模块中代码:
Option ExplicitPublic OldWindowProc As Long
Public TheForm As Form
Public TheMenu As MenuDeclare 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
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPublic 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 = &H2Public 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 TypePrivate TheData As NOTIFYICONDATA
' *********************************************
' The replacement window proc.
' *********************************************
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
' The user clicked on the tray icon.
' Look for click events.
If lParam = WM_LBUTTONUP Then
' On left click, show the form.
If TheForm.WindowState = vbMinimized Then _
TheForm.WindowState = TheForm.LastState
TheForm.SetFocus
Exit Function
End If
If lParam = WM_RBUTTONUP Then
' On right click, show the menu.
TheForm.PopupMenu TheMenu
Exit Function
End If
End If
' Send other messages to the original
' window proc.
NewWindowProc = CallWindowProc( _
OldWindowProc, hwnd, Msg, _
wParam, lParam)
End Function
' *********************************************
' Add the form's icon to the tray.
' *********************************************
Public Sub AddToTray(frm As Form, mnu As Menu)
' ShowInTaskbar must be set to False at
' design time because it is read-only at
' run time. ' Save the form and menu for later use.
Set TheForm = frm
Set TheMenu = mnu
' Install the new WindowProc.
OldWindowProc = SetWindowLong(frm.hwnd, _
GWL_WNDPROC, AddressOf NewWindowProc)
' Install the form's icon in the tray.
With TheData
.uID = 0
.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
Shell_NotifyIcon NIM_ADD, TheData
End Sub
' *********************************************
' Remove the icon from the system tray.
' *********************************************
Public Sub RemoveFromTray()
' Remove the icon from the tray.
With TheData
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
' Restore the original window proc.
SetWindowLong TheForm.hwnd, GWL_WNDPROC, _
OldWindowProc
End Sub
' *********************************************
' Set a new tray tip.
' *********************************************
Public Sub SetTrayTip(tip As String)
With TheData
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
' *********************************************
' Set a new tray icon.
' *********************************************
Public Sub SetTrayIcon(pic As Picture)
' Do nothing if the picture is not an icon.
If pic.Type <> vbPicTypeIcon Then Exit Sub ' Update the tray icon.
With TheData
.hIcon = pic.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub