APIs: Sous classement pour fonctionnalité du SysTray	Author(s) Dev Ashish

Sous-classement pour fonctionnalité du SysTray

 (NDLT: Le SysTray est la portion droite, en bas de l'écran, sur laquelle on retrouve par défaut l'heure et autres icônes particuliers, tel que celui de votre anti-virus, de MS SQL Server, etc. )

    Afficher des icônes de tâches dans le TaskBar est un des traits caractéristiques de Windows 98, Windows 95, et Windows NT 4.0. Pour manipuler un icône dans le Taskbar Status Area,  on peut utiliser la fonction de l'API de Windows Shell_NotifyIcon du dll  Shell32. Cette fonction nous permet d'ajouter, de modifier, d'effacer, d'ajouter un ToolTip et d'envoyer un message (callback) pour exécuter un événement pour la souris.

   Cependant, puisque les formulaires d'Access sont déjà fortement sous classés, il est nécessaire d'écrire du code supplémentaire pour réagir avec succès aux messages provenant du System Tray. Prendre note que la technique montrée ici n'est ni documentée, ni supportée, dans l'environnement de Microsoft Office 97.

    Note: Pour tester le code de cet article, vous devez avoir également le code pour AddressOf.

   Créer un nouveau formulaire avec deux boutons,  cmdStartDemo et cmdEndDemo, puis ajouter le code suivant dans le module de ce formulaire..

'************** Code Start *************
'
'Si vrai, la fenêtre du formulaire est déjà sous-classée
Private mblnSubclassed As Boolean

Private Sub cmdEndDemo_Click()
   'Décrocher le sous-classement
   Call sUnhookTrayIcon(Me)
   mblnSubclassed = False
End Sub

Private Sub cmdStartDemo_Click()
   If Not mblnSubclassed Then
      'Ne pas essauer, et sous-classe deux fois
      Call sHookTrayIcon(Me, "fWndProcTray", "Hello World")
      'si vous avez un icône en main,
      'vous appelez plutôt  sHookTrayIcon comme suit
      'Call sHookTrayIcon(Me, "fWndProcTray", _
            "Hello World", "D:\install\temp\face.ico")
      
      mblnSubclassed = True
   Else
      'si déjà sous-classé, alors
      'simplement cacher la fenête à nouveau
      Me.Visible = False
   End If
End Sub

Private Sub Form_Close()
   If mblnSubclassed Then
      'décroche le sous-clasement et nettoyage
      Call sUnhookTrayIcon(Me)
   End If
End Sub
'************** Code End *************

    Create a new module and paste this code in it.

'************** Code Start *************
'
'------------------------------
'  Ne PAS parcourir ce code PAS-À-PAS.
'  Entrer dans le mode de déverminage
'  causera une erreur, GPF, si la fenêtre est
'  sous-classée.
'------------------------------

'//LoadImage flags
Private Const WM_GETICON = &H7F  'un message est envoyé pour retrouver un handle _
                                                            à un petit ou à un grand icône associé à une fenêtre
Private Const WM_SETICON = &H80  'message pour associer un icône à une fenêtre
Private Const IMAGE_BITMAP = 0      'Charge un bitmap.
Private Const IMAGE_ICON = 1         ' Charge un icône.
Private Const IMAGE_CURSOR = 2   'Charge un curseur.
Private Const LR_LOADFROMFILE = &H10      'Charge l'image du fichier spécifié par le _
                                                                           paramètre lpszName. Si non spécifié _
                                                                           lpszName est le nom d"une ressource
Private Const ICON_SMALL = 0&    'Ramène le petit icône de la fenêtre.
Private Const ICON_BIG = 1&         'Ramène le gros icône de la fenêtre.

'charge un icône, un curseur, ou un 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                          '// obtenir un  icône
Private Const SHGFI_DISPLAYNAME = &H200            '// obtenir le nom du display
Private Const SHGFI_TYPENAME = &H400                  '// obtenir le nom du  type
Private Const SHGFI_ATTRIBUTES = &H800               '// obtenir les attributs
Private Const SHGFI_ICONLOCATION = &H1000       '// obtenir la localisation de l'icône
Private Const SHGFI_EXETYPE = &H2000                   '// retour d'un type exe
Private Const SHGFI_SYSICONINDEX = &H4000         '// obtenir l'index de l'icône
Private Const SHGFI_LINKOVERLAY = &H8000           '// place un lien (link overlay) sur l'icône
Private Const SHGFI_SELECTED = &H10000               '// montrer l'icône en mode choisi
Private Const SHGFI_ATTR_SPECIFIED = &H20000   '// obtenir seulement les attributs spécifiés
Private Const SHGFI_LARGEICON = &H0                    '// obtenir le gros icône
Private Const SHGFI_SMALLICON = &H1                    '// obtenir le petit icône
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 de l'icône représenté par le fichier
   iIcon As Long                                        'Index de l'image de l'icône dnas la liste _
                                                                 d'images du système
   dwAttributes As Long                            'Vecteur indicant les attributs _
                                                                  de l'objet-fichier
   szDisplayName As String * MAX_PATH  'Chaîne contenant le nom du _
                                                                  fichier tel qu'il appraît dans le shell de Windows
   szTypeName As String * 80                   'Chaîne décrivant le type de fichier
End Type

'Repère l'information relative à un objet dans le système de fichiers,
'tel qu'un fichier, un répertoire, une racine, ...
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

'On le déclare ici de sorte qu'on puisse utiliser  DestroyIcon plus loin
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

'choisir l'état voulu de la fenêtre
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          'Ajouter un icône dans la zone du  statut
Private Const NIM_MODIFY As Long = &H1    'Modifier un icône dans la zone du statut
Private Const NIM_DELETE As Long = &H2    'Efface un icône de la zone de statut

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

'//Messages
Private Const WM_MOUSEMOVE = &H200        'posté à une fenêtre lorsque le curseur bouge
Private Const WM_LBUTTONDBLCLK = &H203   ' Double-clic gauche
Private Const WM_LBUTTONDOWN = &H201     ' Bouton gauche enfoncé
Private Const WM_LBUTTONUP = &H202           'Bouton gauche relâché
Private Const WM_RBUTTONDBLCLK = &H206   ' Double-clic droit
Private Const WM_RBUTTONDOWN = &H204    ' Bouton droit enfoncé
Private Const WM_RBUTTONUP = &H205          ' Bouton droit relâché

Private Type NOTIFYICONDATA
  cbSize As Long                      'Dimension de cette  structure, en octets
   hWnd As Long                     'Handle de la fenêtre qui recevra _
                                                le message de notification associé à un  _
                                                icône dans la zone du statut du taskbar
  uID As Long                          'Icône d'dentification maison de l'application,  _
                                                sur le taskbar.
  uFlags As Long                     'Vecteur de  flags indiquant lequel des membres de la  _
                                               structure contient des données valides
  uCallbackMessage As Long  'Message callback défini par l'application
  hIcon As Long                      'Handle de l'icône à ajouter, modifier, ou effacer
  szTip As String * 64              'Pointeur à une chaîne, terminée par le caractère null, _
                                                fournissant le texte du ballon flottant d'aide (tooltip).
End Type

'Envoie un message à la zone du statut du taskbar
Private Declare Function apiShellNotifyIcon Lib "shell32.dll" _
  Alias "Shell_NotifyIconA" _
  (ByVal dwMessage As Long, _
  lpData As NOTIFYICONDATA) _
  As Long
  
'passe l'information du message à la procédure spécifiée
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
  
'change un attribut de la fenêtre spécifiée
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)    'Nouvelle addresse pour la procédure 


Function fWndProcTray(ByVal hWnd As Long, _
                                       ByVal uMessage As Long, _
                                       ByVal wParam As Long, _
                                       ByVal lParam As Long) _
                                       As Long
'reçoit le message indirectement depuis le système d'exploitation
'mais nou permet d'effectuer du travail supplémentaire
'pour quelques uns de ces messages
'
   On Error Resume Next
   
   Select Case lParam
      Case WM_LBUTTONUP:        ' Bouton gauche relâché
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
      
      Case WM_LBUTTONDBLCLK:    'Bouton gauche, Double clic
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
      
      Case WM_LBUTTONDOWN:    'Bouton gauche enfoncé
         'Debug.Print "Left Button Down"
      
      Case WM_RBUTTONDBLCLK:  ' Double-clic droit
         'Debug.Print "Right Button Double Click"
         
      Case WM_RBUTTONDOWN:  'Bouton droit, enoncé
         'Debug.Print "Right button Down"
         
      Case WM_RBUTTONUP:          'Bouton droit, relâché
         Call apiShowWindow(hWnd, SW_SHOWNORMAL)
   End Select
   
   'réflète  les messages
   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)
   'Initialise l'icône du  tray 
   If fInitTrayIcon(frm, strTipText, strIconPath) Then
      'cacher le formulaire
      frm.Visible = False
      
      'addresse du nouvau message handler pour Windows
      lpPrevWndProc = apiSetWindowLong(frm.hWnd, _
                                    GWL_WNDPROC, _
                                    AddrOf(strFunction))
  End If
End Sub

Sub sUnhookTrayIcon(frm As Form)
   'Restaure le message handler original
   Call apiSetWindowLong(frm.hWnd, _
            GWL_WNDPROC, _
            lpPrevWndProc)
   'Enlève l'icône du SysTray
   Call apiShellNotifyIcon(NIM_DELETE, nID)
   
   'Si un icône maison était utilisé, rétablir l'icône
   If mblnCustomIcon Then
      Call fRestoreIcon(frm.hWnd)
   End If
   'Détruire l'icône
   Call apiDestroyIcon(psfi.hIcon)
End Sub

Private Function fExtractIcon() As Long
' Extraire l'icône associé au formulaire Access
'
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)
   'S'assurer qu'il n'y a pas d'erreur
   If Not hIcon = 0 Then fExtractIcon = psfi.hIcon
ExitHere:
   Exit Function
ErrHandler:
   fExtractIcon = False
   Resume ExitHere
End Function

Private Function fRestoreIcon(hWnd As Long)
   'Charger l'icône du formulaire, et l'assigner à la fenêtre
   Call apiSendMessageLong(hWnd, WM_SETICON, 0&, fExtractIcon())
End Function

Private Function fSetIcon(frm As Form, strIconPath As String) As Long
Dim hIcon As Long
   'Icône 16x16 depuis un fichier
   hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
   If hIcon Then
      'S'occuper de l'icône du formulaire
      Call apiSendMessageLong(frm.hWnd, WM_SETICON, 0&, hIcon&)
      'Se rappeler s'il faut rétablir l'icône
      mblnCustomIcon = True
      'et retourner  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

  'Utiliser une chaîne par défaut si l'usager n'en spécifie pas pour le tooltip
   If strTipText = vbNullString Then strTipText = "MSAccess Form"

   If (strIconPath = vbNullString) Or (Dir(strIconPath) = vbNullString) Then
      's'il n'y a pas d'icône de spécifié, utiliser celui du formulaire
      hIcon = fExtractIcon()
   Else
      'charge et afficher l'icône
      hIcon = fSetIcon(frm, strIconPath)
   End If
   
   'Si tout va bien jusqu'à maintenant, continuer en
   'plaçant l'icône dans le 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 *************