CodeItBetter Programming Another VB Programming Blog

'System & API - How to add a System Tray Icon
Option Explicit
 
'A Class that adds a System Tray Icon.
#Const VB_VERSION = 6
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 Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Private t As NOTIFYICONDATA
Private WithEvents pichook As PictureBox
Private mvarToolTip As String
Public Event LButtonDblClk()
Public Event LButtonDown()
Public Event LButtonUp()
Public Event RButtonDblClk()
Public Event RButtonDown()
Public Event RButtonUp()
Private mvarSourceWindow As Form
Private mvarDefaultDblClk As Boolean
 
Public Property Let ToolTip(ByVal vData As String)
    ChangeToolTip vData
End Property
 
Public Property Get ToolTip() As String
    ToolTip = mvarToolTip
End Property
 
Public Property Let Icon(ByVal vData As Variant)
    ChangeIcon vData
End Property
 
Public Property Get Icon() As Variant
    Icon = t.hIcon      'pichook.Picture
End Property
 
Public Property Let DefaultDblClk(ByVal vData As Boolean)
    mvarDefaultDblClk = vData
End Property
 
Public Property Get DefaultDblClk() As Boolean
    DefaultDblClk = mvarDefaultDblClk
End Property
 
Public Property Set SourceWindow(ByVal vData As Form)
    Set mvarSourceWindow = vData
    SetPicHook
End Property
 
Public Property Get SourceWindow() As Form
    Set SourceWindow = mvarSourceWindow
End Property
 
Private Sub Class_Initialize()
    mvarDefaultDblClk = True
    t.cbSize = Len(t)
    t.uId = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.ucallbackMessage = WM_MOUSEMOVE
    t.hIcon = Me.Icon
    t.szTip = Chr$(0)       'Default to no tooltip
End Sub
 
Private Sub pichook_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static rec As Boolean, msg As Long, oldmsg As Long
 
    oldmsg = msg
    msg = X / Screen.TwipsPerPixelX
 
    If rec = False Then
        rec = True
        Select Case msg
        Case WM_LBUTTONDBLCLK:
            LButtonDblClk
        Case WM_LBUTTONDOWN:
            RaiseEvent LButtonDown
        Case WM_LBUTTONUP:
            RaiseEvent LButtonUp
        Case WM_RBUTTONDBLCLK:
            RaiseEvent RButtonDblClk
        Case WM_RBUTTONDOWN:
            RaiseEvent RButtonDown
        Case WM_RBUTTONUP:
            RaiseEvent RButtonUp
        End Select
        rec = False
    End If
End Sub
 
Private Sub LButtonDblClk()
    If mvarDefaultDblClk Then
        mvarSourceWindow.WindowState = vbNormal
        mvarSourceWindow.Show
        App.TaskVisible = True
        RemoveFromSysTray
    End If
 
    RaiseEvent LButtonDblClk
End Sub
 
Public Sub RemoveFromSysTray()
    t.cbSize = Len(t)
    t.hwnd = pichook.hwnd
    t.uId = 1&
    Shell_NotifyIcon NIM_DELETE, t
End Sub
 
Public Sub IconInSysTray()
    Shell_NotifyIcon NIM_ADD, t
End Sub
 
Public Sub MinToSysTray()
    Me.IconInSysTray
    mvarSourceWindow.Hide
    App.TaskVisible = False
End Sub
 
Private Sub SetPicHook()
    On Error GoTo AlreadyAdded
    #If VB_VERSION = 6 Then
        Set pichook = mvarSourceWindow.Controls.Add("VB.PictureBox", "pichook")
    #Else
        Set pichook = mvarSourceWindow.pichook
    #End If
 
    pichook.Visible = False
    pichook.Picture = mvarSourceWindow.Icon
    t.hwnd = pichook.hwnd
 
    Exit Sub
 
AlreadyAdded:
    If Err.Number <> 727 Then  ' pichook has already been added
        MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Error"
        Stop
        Resume
    End If
End Sub
 
Public Sub ChangeIcon(toNewIcon)
    Set pichook.Picture = toNewIcon
    t.hIcon = pichook.Picture
    Shell_NotifyIcon NIM_MODIFY, t
End Sub
 
Public Sub ChangeToolTip(ByVal cNewTip As String)
    mvarToolTip = cNewTip
    t.szTip = cNewTip & Chr$(0)
    Shell_NotifyIcon NIM_MODIFY, t
    If mvarSourceWindow.WindowState = vbMinimized Then
        mvarSourceWindow.Caption = cNewTip
    End If
End Sub
 
'Usage:
Private WithEvents Tray As clsSysTray
 
Private Sub Form_Load()
    Tray = New clsSysTray
    Tray.Icon = Me.Icon
    Tray.SourceWindow = Me.hwnd
    Tray.ToolTip = "This is a System Tray Icon"
End Sub