In article we will learn how to use powerful subclassing technique to implement system tray icon which can show Ondemand Balloon Tooltip, simple mouse over tooltip and right click popup menu.
Basic for system tray icon implementation
You can implement system tray icon using Shell_NotifyIcon API. You will find more information about Shell_NotifyIcon API and NOTIFYICONDATA structure on MSDN.
To make this code reusable as ActiveX component or ActiveX Dll I have created a very easy to use class. Since we know that to use subclassing technique we must provide a window handle which can receive all window messages. This code will create a hidden window as a message receiver so you dont really need any VB form handle to use this class.
Here is few steps for implementing SystemTray icon
- Create a hidden window and get a valid window handle
- Initialize NOTIFYICONDATA structure which we will use through out the code. Make sure that you assign WM_USER_TRAY to uCallbackMessage member of the NOTIFYICONDATA structure. This will only send system tray related messages to our hidden window.
- If hidden window is created the start Hook for that window
- When we start hook we do couple of things
- call RegisterWindowMessage("TaskbarCreated") so system sends WM_TASKBARCREATED message when taskbar is created or refreshed.
- Call SetProp to store class instance pointer as a window property. We might have multiple instances for the same class so we need class object pointer to Fire Events for that instance only.
- Call SetProp to store current window procedure pointer before we bind our window with new window procedure. later we can attach old procedure when we unhook the window.
- Now call SetWindowLong to assign new windows procedure which will process our task bar related messages
- Inside window procedure code try to get object pointer from window handle. Now using the object pointer you can execute ProcessMessage for that instance only. According to lParam and wParam ProcessMessage will raise different event which user can trap inside the code
- In the class_terminate event remove icon from tray, unhook the hidden window, close the hidden window and very last unregister window class which we used for our hidden window.
Now lets see the actual code
Step-By-Step Example - Create a standard exe project - Add one class module, rename it to CBalloonToolTipNotify - Add one standard module (Module1.bas) - Now place 3 textbox, 1 list box, 1 combobox and one commandbutton control on the form1 - Change text2 MultiLine=True and scrollbar=Verticle - Right Click on the form and select menu editor to create the following menu for our tray popup menu |
- Add the following code in form1
Form1.frm |
Click here to copy the following block | Dim WithEvents tt As CBalloonToolTipNotify
Private Sub Command1_Click() SetTip tt.ShowNotifyBalloonTip End Sub
Private Sub Form_Load() Text1 = "Low Disk Space" Text2 = "Your C: Drive is full. " & _ "To complete the installation you atleast need 500MB free." & vbCrLf & vbCrLf & _ "For Moreinfo visit: www.binaryworld.net" Text3 = 5000 Text1.MaxLength = 128 Text2.MaxLength = 256 Combo1.AddItem "(No Icon)" Combo1.AddItem "Information" Combo1.AddItem "Warning" Combo1.AddItem "Error" Combo1.ListIndex = 2 mnuPopup.Visible = False
Set tt = New CBalloonToolTipNotify
tt.ContextMenu = mnuPopup tt.TrayIcon = Me.Icon tt.Visible = True
Call SetTip
Command1.Caption = "Show Balloon ToolTip" End Sub Sub SetTip() tt.BalloonTitle = Text1 tt.BalloonText = Text2 tt.BalloonTimeOut = CInt(Text3) tt.BalloonIconType = Combo1.ListIndex tt.Text = "simple mouse over tip" End Sub
Private Sub Form_Unload(Cancel As Integer) Set tt = Nothing End Sub
Private Sub mnuAbout_Click() MsgBox "This code is provided by Binaryworld" End Sub
Private Sub mnuClose_Click()
Call PostMessage(Me.hwnd, WM_CLOSE, 0&, ByVal 0&) End Sub
Private Sub tt_BalloonClick(X As Long, Y As Long) List1.AddItem "tt_BalloonClick (" & X & "," & Y & ")", 0 End Sub
Private Sub tt_BalloonHide() List1.AddItem "tt_BalloonHide (" & X & "," & Y & ")", 0 End Sub
Private Sub tt_BalloonShow() List1.AddItem "tt_BalloonShow", 0 End Sub
Private Sub tt_BalloonTimeOut() List1.AddItem "tt_BalloonTimeOut", 0 End Sub
Private Sub tt_Click() List1.AddItem "tt_Click", 0 End Sub
Private Sub tt_DoubleClick(Button As Integer, X As Long, Y As Long) List1.AddItem "tt_DoubleClick (" & X & "," & Y & ") Button=" & Button, 0 End Sub
Private Sub tt_MouseDown(Button As Integer, X As Long, Y As Long) List1.AddItem "tt_MouseDown (" & X & "," & Y & ") Button=" & Button, 0 End Sub
Private Sub tt_MouseMove(X As Long, Y As Long) List1.AddItem "tt_MouseMove (" & X & "," & Y & ")", 0 End Sub
Private Sub tt_MouseUp(Button As Integer, X As Long, Y As Long) List1.AddItem "tt_MouseUp (" & X & "," & Y & ") Button=" & Button, 0 End Sub
Private Sub tt_Reload() List1.AddItem "tt_Reload", 0 End Sub |
- Add the following code in module1
Module1.bas |
Click here to copy the following block | Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Long) As Long Public Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Public Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, ByRef lpData As NOTIFYICONDATA) As Boolean
Public Const WM_CLOSE As Long = &H10
Private Const WM_APP As Long = &H8000& Public Const WM_MYHOOK As Long = WM_APP + &H15 Public Const NOTIFYICON_VERSION = &H3
Public Const NIF_MESSAGE = &H1 Public Const NIF_ICON = &H2 Public Const NIF_TIP = &H4 Public Const NIF_STATE = &H8 Public Const NIF_INFO = &H10
Public Const NIM_ADD = &H0 Public Const NIM_MODIFY = &H1 Public Const NIM_DELETE = &H2 Public Const NIM_SETFOCUS = &H3 Public Const NIM_SETVERSION = &H4 Public Const NIM_VERSION = &H5
Public Const NIS_HIDDEN = &H1 Public Const NIS_SHAREDICON = &H2
Public Const NIIF_NONE = &H0 Public Const NIIF_INFO = &H1 Public Const NIIF_WARNING = &H2 Public Const NIIF_ERROR = &H3 Public Const NIIF_GUID = &H5 Public Const NIIF_ICON_MASK = &HF Public Const NIIF_NOSOUND = &H10
Public Type POINTAPI X As Long Y As Long End Type
Public Type WNDCLASS style As Long lpfnwndproc As Long cbClsextra As Long cbWndExtra2 As Long hInstance As Long hIcon As Long hCursor As Long hbrBackground As Long lpszMenuName As Long lpszClassName As String End Type
Public Type NOTIFYICONDATA cbSize As Long hwnd As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 128 dwState As Long dwStateMask As Long szInfo As String * 256 uTimeOutAndVersion As Long szInfoTitle As String * 64 dwInfoFlags As Long End Type
Public Const WM_USER = &H400 Public Const WM_USER_TRAY = WM_USER + 1 Public Const WM_MOUSEMOVE = &H200 Public Const WM_LBUTTONDOWN = &H201 Public Const WM_LBUTTONUP = &H202 Public Const WM_LBUTTONDBLCLK = &H203 Public Const WM_RBUTTONDOWN = &H204 Public Const WM_RBUTTONUP = &H205 Public Const WM_RBUTTONDBLCLK = &H206 Public Const WM_MBUTTONDOWN = &H207 Public Const WM_MBUTTONUP = &H208 Public Const WM_MBUTTONDBLCLK = &H209
Public Const NIN_BALLOONSHOW As Long = &H402 Public Const NIN_BALLOONHIDE As Long = &H403 Public Const NIN_BalloonTimeOut As Long = &H404 Public Const NIN_BALLOONUSERCLICK As Long = &H405
Public Const GWL_WNDPROC = (-4)
Const PROP_OLDWINDOW = "OldWindowProc" Const PROP_OBJPTR = "ObjectPointer"
Public Enum enumEventType DoubleClick MouseDown MouseMove MouseUp BalloonShow BalloonHide BalloonTimeOut BalloonClick Reload End Enum
Public Declare Function RegisterWindowMessage Lib "user32.dll" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public WM_TASKBARCREATED As Long
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If uMsg = WM_USER_TRAY Then Dim ptrWin As Long Dim clsThis As CBalloonToolTipNotify
ptrWin = GetProp(hwnd, PROP_OBJPTR)
If ptrWin <> 0 Then Set clsThis = ObjectFromPtr(ptrWin) Call clsThis.ProcessMessage(uMsg, wParam, lParam) End If End If
WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam) End Function
Public Sub HookWindow(hwnd As Long, obj As Object) Dim ptr As Long
If WM_TASKBARCREATED = 0 Then WM_TASKBARCREATED = RegisterWindowMessage("TaskbarCreated") End If
ptr = ObjPtr(obj)
Call SetProp(hwnd, PROP_OBJPTR, ptr) Call SetProp(hwnd, PROP_OLDWINDOW, GetWindowLong(hwnd, GWL_WNDPROC))
Call SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc) End Sub
Public Sub UnhookWindow(hwnd As Long) Dim ptrOldWinProc As Long ptrOldWinProc = GetProp(hwnd, PROP_OLDWINDOW) If (ptrOldWinProc <> 0) Then Call SetWindowLong(hwnd, GWL_WNDPROC, ptrOldWinProc) End If End Sub
Public Property Get ObjectFromPtr(ByVal lPtr As Long) As CBalloonToolTipNotify Dim oTHis As CBalloonToolTipNotify CopyMemory oTHis, lPtr, 4 Set ObjectFromPtr = oTHis CopyMemory oTHis, 0&, 4 End Property |
- Add the following code in CBalloonToolTipNotify
CBalloonToolTipNotify.cls |
Click here to copy the following block | Private Const HIDDEN_WIN_CLASS_NAME = "VB Tray Class" Private Const HIDDEN_WIN_NAME = "VB Tray Msg Window"
Private uNIF As NOTIFYICONDATA
Public Enum enumIconType ICON_NONE = NIIF_NONE ICON_INFO = NIIF_INFO ICON_WARNING = NIIF_WARNING ICON_ERROR = NIIF_ERROR End Enum
Public Event Click() Public Event DoubleClick(Button As Integer, X As Long, Y As Long) Public Event MouseDown(Button As Integer, X As Long, Y As Long) Public Event MouseUp(Button As Integer, X As Long, Y As Long) Public Event MouseMove(X As Long, Y As Long) Public Event BalloonShow() Public Event BalloonHide() Public Event BalloonTimeOut() Public Event BalloonClick(X As Long, Y As Long) Public Event Reload()
Private m_IsBalloonTip As Boolean Private m_hHiddenMsgWnd As Long Private m_Cur As POINTAPI Private m_ContextMenu As Menu Private m_Visible As Boolean Private m_BalloonTimeOut As Integer Private m_BalloonIconType As enumIconType Private m_TrayIcon As Long Private m_TrayIconPic As StdPicture
Public Property Let ContextMenu(Value As Menu) Set m_ContextMenu = Value End Property Public Property Get ContextMenu() As Menu Set ContextMenu = m_ContextMenu End Property
Public Property Get TrayIcon() As Long TrayIcon = m_TrayIcon End Property Public Property Let TrayIcon(Value As Long) m_TrayIcon = Value
uNIF.uFlags = uNIF.uFlags Or NIF_ICON uNIF.hIcon = Value If Visible = True Then Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property Public Property Let TrayIconPic(Value As StdPicture) TrayIcon = Value.Handle Set m_TrayIconPic = Value End Property
Public Property Get BalloonTimeOut() As Integer BalloonTimeOut = m_BalloonTimeOut End Property Public Property Let BalloonTimeOut(Value As Integer) m_BalloonTimeOut = Value uNIF.uTimeOutAndVersion = Value If Visible Then uNIF.uFlags = uNIF.uFlags Or NIF_TIP Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property
Public Property Get BalloonIconType() As enumIconType BalloonIconType = m_BalloonIconType End Property Public Property Let BalloonIconType(Value As enumIconType) m_BalloonIconType = Value uNIF.dwInfoFlags = CLng(Value) If Visible Then uNIF.uFlags = uNIF.uFlags Or NIF_TIP Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property
Public Property Get Text() As String Text = uNIF.szTip End Property Public Property Let Text(Value As String) uNIF.szTip = Value & vbNullChar If Visible Then uNIF.uFlags = uNIF.uFlags Or NIF_TIP Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property
Public Property Get BalloonTitle() As String BalloonTitle = uNIF.szInfoTitle End Property Public Property Let BalloonTitle(Value As String) uNIF.szInfoTitle = Value & vbNullChar If Visible Then uNIF.uFlags = uNIF.uFlags Or NIF_TIP Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property
Public Property Get BalloonText() As String BalloonText = uNIF.szInfo End Property Public Property Let BalloonText(Value As String) uNIF.szInfo = Value & vbNullChar If Visible Then uNIF.uFlags = uNIF.uFlags Or NIF_TIP Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If End Property
Public Property Get Visible() As Boolean Visible = m_Visible End Property Public Property Let Visible(Value As Boolean) m_Visible = Value
If m_Visible Then Call Shell_NotifyIcon(NIM_ADD, uNIF) Else Call Shell_NotifyIcon(NIM_DELETE, uNIF) End If End Property
Public Sub ShowNotifyBalloonTip(Optional ByVal sText As String = "", _ Optional ByVal sTitle As String = "", _ Optional ByVal nIconType As Integer = -1, _ Optional ByVal nTimeOut As Integer = -1)
With uNIF .uFlags = .uFlags Or NIF_INFO .uTimeOutAndVersion = IIf(nTimeOut = -1, BalloonTimeOut, nTimeOut) .szInfo = IIf(sText = "", BalloonText, sText) .szInfoTitle = IIf(sTitle = "", BalloonTitle, sTitle) .dwInfoFlags = IIf(nIconType = -1, BalloonIconType, nIconType) End With
If Not Visible Then Visible = True Else Call Shell_NotifyIcon(NIM_MODIFY, uNIF) End If
uNIF.uFlags = uNIF.uFlags And Not NIF_INFO End Sub
Friend Sub ProcessMessage(uMsg As Long, wParam As Long, lParam As Long) Select Case uMsg Case WM_USER_TRAY GetCursorPos m_Cur Select Case lParam Case WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK If lParam = WM_LBUTTONDBLCLK Then RaiseEvent DoubleClick(0, m_Cur.X, m_Cur.Y) If lParam = WM_RBUTTONDBLCLK Then RaiseEvent DoubleClick(1, m_Cur.X, m_Cur.Y) If lParam = WM_MBUTTONDBLCLK Then RaiseEvent DoubleClick(2, m_Cur.X, m_Cur.Y) Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN If lParam = WM_LBUTTONDOWN Then RaiseEvent MouseDown(0, m_Cur.X, m_Cur.Y) If lParam = WM_RBUTTONDOWN Then RaiseEvent MouseDown(1, m_Cur.X, m_Cur.Y) If lParam = WM_MBUTTONDOWN Then RaiseEvent MouseDown(2, m_Cur.X, m_Cur.Y) Case WM_MOUSEMOVE RaiseEvent MouseMove(m_Cur.X, m_Cur.Y) Case WM_LBUTTONUP RaiseEvent MouseUp(0, m_Cur.X, m_Cur.Y) RaiseEvent Click Case WM_RBUTTONUP RaiseEvent MouseUp(1, m_Cur.X, m_Cur.Y) RaiseEvent Click If Not (ContextMenu Is Nothing) Then ContextMenu.Parent.PopupMenu ContextMenu End If Case WM_MBUTTONUP RaiseEvent MouseUp(2, m_Cur.X, m_Cur.Y) RaiseEvent Click Case NIN_BALLOONSHOW RaiseEvent BalloonShow Case NIN_BALLOONHIDE RaiseEvent BalloonHide Case NIN_BalloonTimeOut RaiseEvent BalloonTimeOut Case NIN_BALLOONUSERCLICK RaiseEvent BalloonClick(m_Cur.X, m_Cur.Y) Case Else End Select Case WM_TASKBARCREATED RaiseEvent Reload Case Else End Select End Sub
Public Sub Class_Initialize() m_hHiddenMsgWnd = CreateHiddenMsgWindow If m_hHiddenMsgWnd = 0 Then Debug.Print "Failed to create hidden message window"
With uNIF .hwnd = m_hHiddenMsgWnd .cbSize = Len(uNIF) .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE .uTimeOutAndVersion = NOTIFYICON_VERSION .szTip = "" & vbNullChar .uCallbackMessage = WM_USER_TRAY End With
If m_hHiddenMsgWnd <> 0 Then Call HookWindow(m_hHiddenMsgWnd, Me) End Sub
Private Sub Class_Terminate() Visible = False
If m_hHiddenMsgWnd <> 0 Then Call UnhookWindow(m_hHiddenMsgWnd)
SendMessage m_hHiddenMsgWnd, WM_CLOSE, 0, ByVal 0&
UnregisterClass HIDDEN_WIN_CLASS_NAME, App.hInstance Debug.Print "Terminate" End Sub
Private Function CreateHiddenMsgWindow() As Long Dim wc As WNDCLASS wc.style = 0 wc.lpfnwndproc = PtrToFun(AddressOf WindowProc) wc.hInstance = App.hInstance wc.lpszClassName = HIDDEN_WIN_CLASS_NAME RegisterClass wc CreateHiddenMsgWindow = CreateWindowEx(0, HIDDEN_WIN_CLASS_NAME, HIDDEN_WIN_NAME, 0, 0, 0, 100, 100, 0, 0, 0, ByVal 0) End Function
Private Function PtrToFun(ptr As Long) As Long PtrToFun = ptr End Function |
|