API: Subclassing form for SysTray functionality

    One of the new features of the Windows 98, Windows 95, and Windows NT 4.0 user interface is the taskbar status area. To manipulate an icon in the taskbar status area, we can use the Windows API function Shell_NotifyIcon in the Shell32.dll file. This function allows us to add, modify, delete, set a ToolTip string, and send a callback message to execute mouse events

   However, since Access forms are already so heavily subclassed, we need to write additional code to successfully react to messages from the System Tray. Please note that the technique shown here is not at all documented or supported in Microsoft Office 97 environment.

    Note: In order to test the code in this article, you will need the AddressOf code as well.

   Create a new form with two command buttons, called cmdStartDemo and cmdEndDemo; and put the following code in the form's class module.

'************** Code Start *************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
'If true, the form window is already subclassed
Private mblnSubclassed As Boolean

Private Sub cmdEndDemo_Click()
   'Unsubclass the window
   Call sUnhookTrayIcon(Me)
   mblnSubclassed = False
End Sub

Private Sub cmdStartDemo_Click()
   If Not mblnSubclassed Then
      'Don't try and subclass twice
      Call sHookTrayIcon(Me, "fWndProcTray", "Hello World")
      'if you had a custom icon,
      'the call to sHookTrayIcon would be like this
      'Call sHookTrayIcon(Me, "fWndProcTray", _
            "Hello World", "D:\install\temp\face.ico")
      
      mblnSubclassed = True
   Else
      'if already subclassed, then
      'simply hide the window again
      Me.Visible = False
   End If
End Sub

Private Sub Form_Close()
   If mblnSubclassed Then
      'unsubclass and cleanup
      Call sUnhookTrayIcon(Me)
   End If
End Sub
'************** Code End *************

    Create a new module and paste this code in it.

'************** Code Start *************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
'
'------------------------------
'  Do NOT try to step through
'  this code.  Entering debug mode
'  will cause a GPF if the window
'  is subclassed.
'------------------------------

'//LoadImage flags
Private Const WM_GETICON = &H7F  'message is sent to a window to retrieve a handle _
                                                            to the large or small icon associated with a window
Private Const WM_SETICON = &H80  'message to associate a new large or small icon with a window
Private Const IMAGE_BITMAP = 0      'Loads a bitmap.
Private Const IMAGE_ICON = 1         ' Loads an icon.
Private Const IMAGE_CURSOR = 2   'Loads a cursor.
Private Const LR_LOADFROMFILE = &H10      'Loads the image from the file specified by _
                                                                           the lpszName parameter. If this flag is not _
                                                                           specified, lpszName is the name of the resource.
Private Const ICON_SMALL = 0&    'Retrieve the small icon for the window.
Private Const ICON_BIG = 1&         'Retrieve the large icon for the window.

'loads an icon, cursor, or bitmap.
Private Declare Function apiLoadImage Lib "user32" _
   Alias "LoadImageA" _
   (ByVal hInst As Long, _
   ByVal lpszName As String, _
   ByVal uType As Long, _
   ByVal cxDesired As Long, _
   ByVal cyDesired As Long, _
   ByVal fuLoad As Long) _
   As Long

Private Declare Function apiSendMessageLong Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long) _
   As Long

'//SHGetFileInfo flags
Private Const SHGFI_ICON = &H100                          '// get icon
Private Const SHGFI_DISPLAYNAME = &H200            '// get display name
Private Const SHGFI_TYPENAME = &H400                  '// get type name
Private Const SHGFI_ATTRIBUTES = &H800               '// get attributes
Private Const SHGFI_ICONLOCATION = &H1000       '// get icon location
Private Const SHGFI_EXETYPE = &H2000                   '// return exe type
Private Const SHGFI_SYSICONINDEX = &H4000         '// get system icon index
Private Const SHGFI_LINKOVERLAY = &H8000           '// put a link overlay on icon
Private Const SHGFI_SELECTED = &H10000               '// show icon in selected state
Private Const SHGFI_ATTR_SPECIFIED = &H20000   '// get only specified attributes
Private Const SHGFI_LARGEICON = &H0                    '// get large icon
Private Const SHGFI_SMALLICON = &H1                    '// get small icon
Private Const SHGFI_OPENICON = &H2                     '// get open icon
Private Const SHGFI_SHELLICONSIZE = &H4             '// get shell size icon
Private Const SHGFI_PIDL = &H8                               '// pszPath is a pidl
Private Const SHGFI_USEFILEATTRIBUTES = &H10  '// use passed dwFileAttribute

Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260

Private Type SHFILEINFO
   hIcon As Long                                      'Handle to the icon that represents the file.
   iIcon As Long                                        'Index of the icon image within the _
                                                                 system image list.
   dwAttributes As Long                            'Array of values that indicates the _
                                                                  attributes of the file object.
   szDisplayName As String * MAX_PATH  'String that contains the name of the _
                                                                  file as it appears in the Windows shell
   szTypeName As String * 80                   'String that describes the type of file.
End Type

'Retrieves information about an object in the file system,
'such as a file, a folder, a directory, or a drive root.
Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _
   Alias "SHGetFileInfoA" _
   (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) _
    As Long
        
Private Declare Function apiDestroyIcon Lib "user32" _
   Alias "DestroyIcon" _
   (ByVal hIcon As Long) _
   As Long

'Declared here so we can use DestroyIcon afterwards
Private psfi As SHFILEINFO

'//ShowWindow flags
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3

'sets the specified window's show state.
Private Declare Function apiShowWindow Lib "user32" _
   Alias "ShowWindow" _
   (ByVal hWnd As Long, _
   ByVal nCmdShow As Long) _
   As Long

'//Shell_NotifyIcon Flags
Private Const NIM_ADD As Long = &H0          'Add an icon to the status area.
Private Const NIM_MODIFY As Long = &H1    'Modify an icon in the status area.
Private Const NIM_DELETE As Long = &H2    'Delete an icon from the status area.

'//NOTIFYICONDATA flags
Private Const NIF_TIP As Long = &H4             'The szTip member is valid.
Private Const NIF_MESSAGE As Long = &H1   'The uCallbackMessage member is valid.
Private Const NIF_ICON As Long = &H2         'The hIcon member is valid.

'//Messages
Private Const WM_MOUSEMOVE = &H200        'posted to a window when the cursor moves.
Private Const WM_LBUTTONDBLCLK = &H203   'Left Double-click
Private Const WM_LBUTTONDOWN = &H201     'Left Button down
Private Const WM_LBUTTONUP = &H202           'Left Button up
Private Const WM_RBUTTONDBLCLK = &H206   'Right Double-click
Private Const WM_RBUTTONDOWN = &H204    'Right Button down
Private Const WM_RBUTTONUP = &H205          'Right Button up

Private Type NOTIFYICONDATA
  cbSize As Long                      'Size of this structure, in bytes.
   hWnd As Long                     'Handle to the window that will receive _
                                                notification messages associated with an _
                                                icon in the taskbar status area
  uID As Long                          'Application-defined identifier of the _
                                                taskbar icon.
  uFlags As Long                     'Array of flags that indicate which of _
                                               the other members contain valid data.
  uCallbackMessage As Long  'Application-defined message identifier.
  hIcon As Long                      'Handle to the icon to be added, modified, _
                                                or deleted
  szTip As String * 64              'Pointer to a NULL-terminated string _
                                                with the text for a standard tooltip.
End Type

'Sends a message to the taskbar's status area.
Private Declare Function apiShellNotifyIcon Lib "shell32.dll" _
  Alias "Shell_NotifyIconA" _
  (ByVal dwMessage As Long, _
  lpData As NOTIFYICONDATA) _
  As Long
  
'passes message information to the specified window procedure.
Private Declare Function apiCallWindowProc 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
  
'changes an attribute of the specified window.
Private Declare Function apiSetWindowLong Lib "user32" _
  Alias "SetWindowLongA" _
  (ByVal hWnd As Long, _
  ByVal nIndex As Long, _
  ByVal wNewWord As Long) _
  As Long
  
Private nID As NOTIFYICONDATA
Private lpPrevWndProc As Long
Private mblnCustomIcon As Boolean

Private Const GWL_WNDPROC  As Long = (-4)    'Sets a new address for the window procedure.


Function fWndProcTray(ByVal hWnd As Long, _
                                       ByVal uMessage As Long, _
                                       ByVal wParam As Long, _
                                       ByVal lParam As Long) _
                                       As Long
'receives messages indirectly from the operating system
'but allows us to perform additional functions
'for some of those messages.
'
   On Error Resume Next
   
   Select Case lParam
      Case WM_LBUTTONUP:        'Left Button Up
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
      
      Case WM_LBUTTONDBLCLK:    'Left Button Double click
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
      
      Case WM_LBUTTONDOWN:    'Left Button down
         'Debug.Print "Left Button Down"
      
      Case WM_RBUTTONDBLCLK:  'Right Double-click
         'Debug.Print "Right Button Double Click"
         
      Case WM_RBUTTONDOWN:  'Right Button down
         'Debug.Print "Right button Down"
         
      Case WM_RBUTTONUP:          'Right Button Up
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
   End Select
   
   'return the messages back
   fWndProcTray = apiCallWindowProc( _
                                       ByVal lpPrevWndProc, _
                                       ByVal hWnd, _
                                       ByVal uMessage, _
                                       ByVal wParam, _
                                       ByVal lParam)
End Function

Sub sHookTrayIcon(frm As Form, _
                                 strFunction As String, _
                                 Optional strTipText As String, _
                                 Optional strIconPath As String)
   'Initialize the tray icon first
   If fInitTrayIcon(frm, strTipText, strIconPath) Then
      'hide the form window
      frm.Visible = False
      
      'Set new address for window's message handler
      lpPrevWndProc = apiSetWindowLong(frm.hWnd, _
                                    GWL_WNDPROC, _
                                    AddrOf(strFunction))
  End If
End Sub

Sub sUnhookTrayIcon(frm As Form)
   'Restore the original message handler
   Call apiSetWindowLong(frm.hWnd, _
            GWL_WNDPROC, _
            lpPrevWndProc)
   'Remove the icon in the SysTray
   Call apiShellNotifyIcon(NIM_DELETE, nID)
   
   'If a custom icon was used, reset the form's icon
   If mblnCustomIcon Then
      Call fRestoreIcon(frm.hWnd)
   End If
   'Destroy the icon
   Call apiDestroyIcon(psfi.hIcon)
End Sub

Private Function fExtractIcon() As Long
' Extracts the icon associated with an Access form
'
On Error GoTo ErrHandler
Dim hIcon As Long

   'Don't need the full file name as Access form shortcuts
   'have MAF extension.  The SHGFI_USEFILEATTRIBUTES
   'lets us pass an "invalid" file name to SHGetFileInfo
   hIcon = apiSHGetFileInfo(".MAF", FILE_ATTRIBUTE_NORMAL, _
                              psfi, LenB(psfi), _
                              SHGFI_USEFILEATTRIBUTES Or _
                              SHGFI_SMALLICON Or SHGFI_ICON)
   'Make sure there were no errors
   If Not hIcon = 0 Then fExtractIcon = psfi.hIcon
ExitHere:
   Exit Function
ErrHandler:
   fExtractIcon = False
   Resume ExitHere
End Function

Private Function fRestoreIcon(hWnd As Long)
   'Load the default form icon and assign it to the window
   Call apiSendMessageLong(hWnd, WM_SETICON, 0&, fExtractIcon())
End Function

Private Function fSetIcon(frm As Form, strIconPath As String) As Long
Dim hIcon As Long
   'Load the 16x16 icon from file
   hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
   If hIcon Then
      'First set the form's icon
      Call apiSendMessageLong(frm.hWnd, WM_SETICON, 0&, hIcon&)
      'This will tell us afterwards if we need to reset the form's icon
      mblnCustomIcon = True
      'Now return the hIcon
      fSetIcon = hIcon
   End If
End Function

Private Function fInitTrayIcon(frm As Form, strTipText As String, strIconPath As String) As Boolean
Dim hIcon As Long

   'If the user didn't specify the tip text, use a default value
   If strTipText = vbNullString Then strTipText = "MSAccess Form"

   If (strIconPath = vbNullString) Or (Dir(strIconPath) = vbNullString) Then
      'if there's no icon specified, use the form's default icon
      hIcon = fExtractIcon()
   Else
      'load and set the icon
      hIcon = fSetIcon(frm, strIconPath)
   End If
   
   'If we were successful in previous step, then continue
   'to place the icon in the system tray
   If hIcon Then
      With nID
         .cbSize = LenB(nID)
         .hWnd = frm.hWnd
         .uID = vbNull
         .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
         .uCallbackMessage = WM_MOUSEMOVE
         .hIcon = hIcon
         .szTip = strTipText & vbNullChar
      End With
      Call apiShellNotifyIcon(NIM_ADD, nID)
      fInitTrayIcon = True
   End If
End Function
'************** Code End *************