Mettre une icônes dans la barre de taches

Soyez le premier à donner votre avis sur cette source.

Snippet vu 17 554 fois - Téléchargée 70 fois

Contenu du snippet

Prenez un module, une form avec un bouton et mettez une icone a votre form.

Source / Exemple :


A mettre dans un module :

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

Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
'
Public Const GWL_WNDPROC = -4
'
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_LBUTTONDBLCLK = &H203
Public Const TPM_RIGHTALIGN = &H8&
'
Public lpPrevWndProc As Long
Public ghWnd As Long
'
Declare Function Shell_NotifyIconA Lib _
    "shell32" (ByVal dwMessage As Long, _
    lpData As NOTIFYICONDATA) As Integer
    
'
'*** Fonctions Windows ***
'
Declare 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 GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function SetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long

'*************************
    

Public Sub IconToTray(frx As Form, msgTip$, Flag As Boolean)
Dim nd    As NOTIFYICONDATA
Dim dMSG  As Long
Dim RetVal  As Integer
'
With nd
    .szTip = msgTip$ & Chr$(0)
    .cbSize = Len(nd)
    .hwnd = frx.hwnd
    .uID = 1
    .uCallbackMessage = WM_LBUTTONDOWN
    .hIcon = frx.Icon
    .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
End With
'
If Flag Then dMSG = NIM_ADD Else dMSG = NIM_DELETE
RetVal = Shell_NotifyIconA(dMSG, nd)

End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If hw = Form1.hwnd Then
   If lParam = WM_LBUTTONDBLCLK Then
        Form1.Show vbModeless
   ElseIf lParam = WM_RBUTTONDOWN Then
           MontrerMenu
   Else
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End If
Else
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End If

End Function

Public Sub HookWindow()
lpPrevWndProc = SetWindowLong(ghWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub Unhookwindow()
Dim RetVal As Long
'
RetVal = SetWindowLong(ghWnd, GWL_WNDPROC, lpPrevWndProc)

End Sub

Public Sub MontrerMenu()
Dim hMenu As Long
Dim hSousMenu As Long
Dim RetVal As Long

'
hMenu = GetMenu(frmMenu.hwnd)
hSousMenu = GetSubMenu(hMenu, 0)
'
SetMenuDefaultItem hSousMenu, 0, True
    With Screen
        w& = (.Width \ .TwipsPerPixelX) * 0.8
        h& = (.Height \ .TwipsPerPixelY)
    End With
    
RetVal = TrackPopupMenu(hSousMenu, TPM_RIGHTALIGN, w&, h&, 0&, frmMenu.hwnd, ByVal 0&)
End Sub

A mettre dans votre form :

    Option Explicit

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Load()
   ghWnd = Me.hwnd
   HookWindow
   IconToTray Me, "CECI est un Test", True
   Me.Hide
End Sub

Private Sub Form_Unload(Cancel As Integer)
   IconToTray Me, "", False
   Unhookwindow
End Sub

A voir également

Ajouter un commentaire

Commentaires

Messages postés
89
Date d'inscription
lundi 3 mars 2003
Statut
Membre
Dernière intervention
28 juillet 2008

Bonjour
Beaucoup de fautes d'orthographe et de précipitations pour rien
Cela ne fonctionne pas
Le bon code avec Explicit
Public Sub MontrerMenu()
Dim hMenu As Long
Dim hSousmenu As Long
Dim RetVal As Long
Dim p As POINT_TYPE
Dim w As Long
Dim h As Long

GetCursorPos p

hMenu = GetMenu(frmmenu.hwnd)
hSousmenu = GetSubMenu(hMenu, 0)
'
SetMenuDefaultItem hSousmenu, 0, True
With Screen
w = p.x
h = p.y
End With

RetVal = TrackPopupMenu(hSousmenu, TPM_RIGHTALIGN, w&, h&, 0&, frmmenu.hwnd, ByVal 0&)
End Sub

Maurice
Messages postés
1
Date d'inscription
vendredi 29 avril 2005
Statut
Membre
Dernière intervention
13 mai 2005

mais ou est le zip stp
Messages postés
780
Date d'inscription
lundi 16 décembre 2002
Statut
Membre
Dernière intervention
16 avril 2009
1
LE ZIPPPPPPP PLEASE !!!!!
Messages postés
19
Date d'inscription
lundi 20 janvier 2003
Statut
Membre
Dernière intervention
24 juillet 2007

Ton code est vraiment super, mais si tu y metteia un zip ou quelque chose dans le genre, ca serai super.
Merci
Messages postés
112
Date d'inscription
mercredi 28 août 2002
Statut
Membre
Dernière intervention
13 mars 2004

vi .. le zip please
Afficher les 16 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.