créer un menu

Salut

copie d'une message de Denis Michon, qui fait lui-même une copie d'un
message de Laurent Longre

Bon, j'ai retrouvé un message du petit jésus à 4 plumes
quant à la possibilité de créer des menus contextuels sur
un formulaire ....

Voici le message dans son intégralité :


Pour créer des menus contextuels de contrôles (ListBox, CommandButton
etc.), même chose en agrandissant le tableau hMenu() et en stockant
chacun des menus créés (handles) dans ce tableau. Ensuite, il suffit de
recopier le code de UserForm_MouseDown dans la procédure MouseDown du
contrôle concerné, et de remplacer hMenu(1) dans ce code par l'indice du
menu qui doit être attaché au contrôle.

J'espère que tu vas pouvoir adapter tout ça à tes besoins !

Laurent

'================================== ' DANS LE MODULE DE CODE DU USERFORM
'==================================
#If Not VBA6 Then

Private Declare Function EbGetExecutingProj Lib "Vba332.dll" _
(hProject As Long) As Long

Private Declare Function TipGetFunctionId Lib "Vba332.dll" _
(ByVal hProject As Long, ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long

Private Declare Function TipGetLpfnOfFunctionId Lib "Vba332.dll" _
(ByVal hProject As Long, ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long

Dim AddrOf As Long

#End If

Private Type POINTAPI
x As Long
y As Long
End Type

Private Declare Function CreatePopupMenu Lib "User32" () As Long

Private Declare Function DestroyMenu Lib "User32" _
(ByVal hMenu As Long) As Long

Private Declare Function TrackPopupMenuEx Lib "User32" _
(ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, _
ByVal n2 As Long, ByVal hWnd As Long, _
ByVal lpTPMParams As Long) As Boolean

Private Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetCursorPos Lib "User32" _
(lpPoint As POINTAPI) As Long

Private Declare Function AppendMenuA Lib "User32" _
(ByVal hMenu As Long, ByVal wFlags As Long, _
ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long

Private Declare Function GetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function DefWindowProcA Lib "User32" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Const COMMANDE As Long = 0
Const SEPARATEUR As Long = &H800
Const SOUSMENU As Long = &H10

Dim hWnd As Long
Dim hMenu(1 To 3) As Long
Dim C As Collection

Private Sub ContextMenu_Click()
MsgBox C(CmdNum)(0) & ", commande " & C(CmdNum)(1)
End Sub

Private Sub AjoutCommande(hMenu As Long, MType As Long, _
Optional NomMenu As String, Optional NomCmd, Optional hSMenu As Long)

Static I As Integer

Select Case MType
Case COMMANDE
I = I + 1
AppendMenuA hMenu, 0, I, CStr(NomCmd)
C.Add Array(NomMenu, NomCmd), CStr(I)
Case SEPARATEUR
AppendMenuA hMenu, SEPARATEUR, 0, vbNullString
Case SOUSMENU
AppendMenuA hMenu, SOUSMENU, hSMenu, NomMenu
End Select

End Sub

Private Sub UserForm_Initialize()

Dim Elt, I As Integer

#If Not VBA6 Then
Dim hProject As Long, strID As String
EbGetExecutingProj hProject
TipGetFunctionId hProject, StrConv("WindowProc", vbUnicode), strID
TipGetLpfnOfFunctionId hProject, strID, AddrOf
#End If
hWnd = FindWindowA("ThunderXFrame", Me.Caption)
Set C = New Collection

For I = 1 To 3
hMenu(I) = CreatePopupMenu
Next I
For Each Elt In Array("1-1", "1-2", "1-3")
AjoutCommande hMenu(2), COMMANDE, "Sous-Menu 1", Elt
Next Elt
For Each Elt In Array("2-1", "2-2", "2-3")
AjoutCommande hMenu(3), COMMANDE, "Sous-Menu 2", Elt
Next Elt
AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 1", hSMenu:=hMenu(2)
AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 2", hSMenu:=hMenu(3)
AjoutCommande hMenu(1), SEPARATEUR
For Each Elt In Array("Commande 1", "Commande 2", "Commande 3")
AjoutCommande hMenu(1), COMMANDE, "Menu 1", Elt
Next Elt

End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

Dim P As POINTAPI, Prev As Long

If Button <> 2 Then Exit Sub
CmdNum = 0
Prev = GetWindowLongA(hWnd, -4)
#If VBA6 Then
SetWindowLongA hWnd, -4, AddressOf WindowProc
#Else
SetWindowLongA hWnd, -4, AddrOf
#End If
GetCursorPos P
TrackPopupMenuEx hMenu(1), 2, P.x, P.y, hWnd, 0
DoEvents
SetWindowLongA hWnd, -4, Prev
If CmdNum Then ContextMenu_Click

End Sub

Private Sub UserForm_Terminate()
Dim I As Integer
For I = 1 To 3
DestroyMenu hMenu(I)
Next I
End Sub

'================================== ' DANS UN MODULE STANDARD
'==================================
Public CmdNum As Long

Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = &H111 Then CmdNum = wParam
WindowProc = 1
End Function

'==================================
"msillienne" <msillienne@nospamjenaimarre.com> a écrit dans le message de
news: 238b01c3af56$a5edf6f0$a601280a@phx.gbl...

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

Ayoye

"msillienne" <msillienne@nospamjenaimarre.com> a écrit dans le message
de news:238b01c3af56$a5edf6f0$a601280a@phx.gbl...

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

ca me crée une erreur sur la vbalib332
et franchement j'ai pas tout compris

-----Message d'origine-----
Salut

copie d'une message de Denis Michon, qui fait lui-même
une copie d'un

message de Laurent Longre

Bon, j'ai retrouvé un message du petit jésus à 4 plumes
quant à la possibilité de créer des menus contextuels
sur

un formulaire ....

Voici le message dans son intégralité :


Pour créer des menus contextuels de contrôles (ListBox,
CommandButton

etc.), même chose en agrandissant le tableau hMenu() et
en stockant

chacun des menus créés (handles) dans ce tableau.
Ensuite, il suffit de

recopier le code de UserForm_MouseDown dans la procédure
MouseDown du

contrôle concerné, et de remplacer hMenu(1) dans ce code
par l'indice du

menu qui doit être attaché au contrôle.

J'espère que tu vas pouvoir adapter tout ça à tes
besoins !

Laurent

'======================== ===========
' DANS LE MODULE DE CODE DU USERFORM
'======================== ===========

#If Not VBA6 Then

Private Declare Function EbGetExecutingProj
Lib "Vba332.dll" _

(hProject As Long) As Long

Private Declare Function TipGetFunctionId
Lib "Vba332.dll" _

(ByVal hProject As Long, ByVal strFunctionName As
String, _

ByRef strFunctionId As String) As Long

Private Declare Function TipGetLpfnOfFunctionId
Lib "Vba332.dll" _

(ByVal hProject As Long, ByVal strFunctionId As
String, _

ByRef lpfn As Long) As Long

Dim AddrOf As Long

#End If

Private Type POINTAPI
x As Long
y As Long
End Type

Private Declare Function CreatePopupMenu Lib "User32" ()
As Long

Private Declare Function DestroyMenu Lib "User32" _
(ByVal hMenu As Long) As Long

Private Declare Function TrackPopupMenuEx Lib "User32" _
(ByVal hMenu As Long, ByVal un As Long, ByVal n1 As
Long, _

ByVal n2 As Long, ByVal hWnd As Long, _
ByVal lpTPMParams As Long) As Boolean

Private Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As
String) As Long

Private Declare Function GetCursorPos Lib "User32" _
(lpPoint As POINTAPI) As Long

Private Declare Function AppendMenuA Lib "User32" _
(ByVal hMenu As Long, ByVal wFlags As Long, _
ByVal wIDNewItem As Long, ByVal lpNewItem As String)
As Long

Private Declare Function GetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function DefWindowProcA Lib "User32" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, _

ByVal lParam As Long) As Long

Const COMMANDE As Long = 0
Const SEPARATEUR As Long = &H800
Const SOUSMENU As Long = &H10

Dim hWnd As Long
Dim hMenu(1 To 3) As Long
Dim C As Collection

Private Sub ContextMenu_Click()
MsgBox C(CmdNum)(0) & ", commande " & C(CmdNum)(1)
End Sub

Private Sub AjoutCommande(hMenu As Long, MType As Long, _
Optional NomMenu As String, Optional NomCmd, Optional
hSMenu As Long)

Static I As Integer

Select Case MType
Case COMMANDE
I = I + 1
AppendMenuA hMenu, 0, I, CStr(NomCmd)
C.Add Array(NomMenu, NomCmd), CStr(I)
Case SEPARATEUR
AppendMenuA hMenu, SEPARATEUR, 0, vbNullString
Case SOUSMENU
AppendMenuA hMenu, SOUSMENU, hSMenu, NomMenu
End Select

End Sub

Private Sub UserForm_Initialize()

Dim Elt, I As Integer

#If Not VBA6 Then
Dim hProject As Long, strID As String
EbGetExecutingProj hProject
TipGetFunctionId hProject, StrConv("WindowProc",
vbUnicode), strID

TipGetLpfnOfFunctionId hProject, strID, AddrOf
#End If
hWnd = FindWindowA("ThunderXFrame", Me.Caption)
Set C = New Collection

For I = 1 To 3
hMenu(I) = CreatePopupMenu
Next I
For Each Elt In Array("1-1", "1-2", "1-3")
AjoutCommande hMenu(2), COMMANDE, "Sous-Menu 1", Elt
Next Elt
For Each Elt In Array("2-1", "2-2", "2-3")
AjoutCommande hMenu(3), COMMANDE, "Sous-Menu 2", Elt
Next Elt
AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 1",
hSMenu:=hMenu(2)

AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 2",
hSMenu:=hMenu(3)

AjoutCommande hMenu(1), SEPARATEUR
For Each Elt In Array("Commande 1", "Commande
2", "Commande 3")

AjoutCommande hMenu(1), COMMANDE, "Menu 1", Elt
Next Elt

End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As
Single)

Dim P As POINTAPI, Prev As Long

If Button <> 2 Then Exit Sub
CmdNum = 0
Prev = GetWindowLongA(hWnd, -4)
#If VBA6 Then
SetWindowLongA hWnd, -4, AddressOf WindowProc
#Else
SetWindowLongA hWnd, -4, AddrOf
#End If
GetCursorPos P
TrackPopupMenuEx hMenu(1), 2, P.x, P.y, hWnd, 0
DoEvents
SetWindowLongA hWnd, -4, Prev
If CmdNum Then ContextMenu_Click

End Sub

Private Sub UserForm_Terminate()
Dim I As Integer
For I = 1 To 3
DestroyMenu hMenu(I)
Next I
End Sub

'======================== ===========
' DANS UN MODULE STANDARD
'======================== ===========

Public CmdNum As Long

Function WindowProc(ByVal hWnd As Long, ByVal Msg As
Long, _

ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = &H111 Then CmdNum = wParam
WindowProc = 1
End Function

'======================== ===========

"msillienne" <msillienne@nospamjenaimarre.com> a écrit
dans le message de

news: 238b01c3af56$a5edf6f0$a601280a@phx.gbl...

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

.

;-))

et franchement j'ai pas tout compris

moi non plus !
mais, c'est tout ce que j'avais sous la main, et guère le temps de
décortiquer

attends, on verra si quelqu'un reprend le flambeau sur ce type de
problèmataon,
ceci dit qu'appelles-tu faire un menu sur un userform ? il n' y a peut-être
pas besoin d'utiliser des procédures si sophitiqués.

a+
rural thierry

<anonymous@discussions.microsoft.com> a écrit dans le message de news:
038701c3af61$14583740$a001280a@phx.gbl...
ca me crée une erreur sur la vbalib332
et franchement j'ai pas tout compris

-----Message d'origine-----
Salut

copie d'une message de Denis Michon, qui fait lui-même
une copie d'un

message de Laurent Longre

Bon, j'ai retrouvé un message du petit jésus à 4 plumes
quant à la possibilité de créer des menus contextuels
sur

un formulaire ....

Voici le message dans son intégralité :


Pour créer des menus contextuels de contrôles (ListBox,
CommandButton

etc.), même chose en agrandissant le tableau hMenu() et
en stockant

chacun des menus créés (handles) dans ce tableau.
Ensuite, il suffit de

recopier le code de UserForm_MouseDown dans la procédure
MouseDown du

contrôle concerné, et de remplacer hMenu(1) dans ce code
par l'indice du

menu qui doit être attaché au contrôle.

J'espère que tu vas pouvoir adapter tout ça à tes
besoins !

Laurent

'================================== >' DANS LE MODULE DE CODE DU USERFORM
'================================== >
#If Not VBA6 Then

Private Declare Function EbGetExecutingProj
Lib "Vba332.dll" _

(hProject As Long) As Long

Private Declare Function TipGetFunctionId
Lib "Vba332.dll" _

(ByVal hProject As Long, ByVal strFunctionName As
String, _

ByRef strFunctionId As String) As Long

Private Declare Function TipGetLpfnOfFunctionId
Lib "Vba332.dll" _

(ByVal hProject As Long, ByVal strFunctionId As
String, _

ByRef lpfn As Long) As Long

Dim AddrOf As Long

#End If

Private Type POINTAPI
x As Long
y As Long
End Type

Private Declare Function CreatePopupMenu Lib "User32" ()
As Long

Private Declare Function DestroyMenu Lib "User32" _
(ByVal hMenu As Long) As Long

Private Declare Function TrackPopupMenuEx Lib "User32" _
(ByVal hMenu As Long, ByVal un As Long, ByVal n1 As
Long, _

ByVal n2 As Long, ByVal hWnd As Long, _
ByVal lpTPMParams As Long) As Boolean

Private Declare Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As
String) As Long

Private Declare Function GetCursorPos Lib "User32" _
(lpPoint As POINTAPI) As Long

Private Declare Function AppendMenuA Lib "User32" _
(ByVal hMenu As Long, ByVal wFlags As Long, _
ByVal wIDNewItem As Long, ByVal lpNewItem As String)
As Long

Private Declare Function GetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLongA Lib "User32" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function DefWindowProcA Lib "User32" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, _

ByVal lParam As Long) As Long

Const COMMANDE As Long = 0
Const SEPARATEUR As Long = &H800
Const SOUSMENU As Long = &H10

Dim hWnd As Long
Dim hMenu(1 To 3) As Long
Dim C As Collection

Private Sub ContextMenu_Click()
MsgBox C(CmdNum)(0) & ", commande " & C(CmdNum)(1)
End Sub

Private Sub AjoutCommande(hMenu As Long, MType As Long, _
Optional NomMenu As String, Optional NomCmd, Optional
hSMenu As Long)

Static I As Integer

Select Case MType
Case COMMANDE
I = I + 1
AppendMenuA hMenu, 0, I, CStr(NomCmd)
C.Add Array(NomMenu, NomCmd), CStr(I)
Case SEPARATEUR
AppendMenuA hMenu, SEPARATEUR, 0, vbNullString
Case SOUSMENU
AppendMenuA hMenu, SOUSMENU, hSMenu, NomMenu
End Select

End Sub

Private Sub UserForm_Initialize()

Dim Elt, I As Integer

#If Not VBA6 Then
Dim hProject As Long, strID As String
EbGetExecutingProj hProject
TipGetFunctionId hProject, StrConv("WindowProc",
vbUnicode), strID

TipGetLpfnOfFunctionId hProject, strID, AddrOf
#End If
hWnd = FindWindowA("ThunderXFrame", Me.Caption)
Set C = New Collection

For I = 1 To 3
hMenu(I) = CreatePopupMenu
Next I
For Each Elt In Array("1-1", "1-2", "1-3")
AjoutCommande hMenu(2), COMMANDE, "Sous-Menu 1", Elt
Next Elt
For Each Elt In Array("2-1", "2-2", "2-3")
AjoutCommande hMenu(3), COMMANDE, "Sous-Menu 2", Elt
Next Elt
AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 1",
hSMenu:=hMenu(2)

AjoutCommande hMenu(1), SOUSMENU, "Sous-menu 2",
hSMenu:=hMenu(3)

AjoutCommande hMenu(1), SEPARATEUR
For Each Elt In Array("Commande 1", "Commande
2", "Commande 3")

AjoutCommande hMenu(1), COMMANDE, "Menu 1", Elt
Next Elt

End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As
Single)

Dim P As POINTAPI, Prev As Long

If Button <> 2 Then Exit Sub
CmdNum = 0
Prev = GetWindowLongA(hWnd, -4)
#If VBA6 Then
SetWindowLongA hWnd, -4, AddressOf WindowProc
#Else
SetWindowLongA hWnd, -4, AddrOf
#End If
GetCursorPos P
TrackPopupMenuEx hMenu(1), 2, P.x, P.y, hWnd, 0
DoEvents
SetWindowLongA hWnd, -4, Prev
If CmdNum Then ContextMenu_Click

End Sub

Private Sub UserForm_Terminate()
Dim I As Integer
For I = 1 To 3
DestroyMenu hMenu(I)
Next I
End Sub

'================================== >' DANS UN MODULE STANDARD
'================================== >
Public CmdNum As Long

Function WindowProc(ByVal hWnd As Long, ByVal Msg As
Long, _

ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = &H111 Then CmdNum = wParam
WindowProc = 1
End Function

'================================== >
"msillienne" <msillienne@nospamjenaimarre.com> a écrit
dans le message de

news: 238b01c3af56$a5edf6f0$a601280a@phx.gbl...

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

.

ben en fait j'ai un use form qui ce lance au démarrage et
pour l'instant il y a des bouton qui permet de faire
plusieur chose mais c'est pas éstétique alors j'ai penser
au menu c'est plus bo :-) comme ca j'aurais un menus du
style : Fichier Edition MenuPerso etc...
mais si y a plus simple je prend
merci

Bonjour,
Tu trouveras un exemple de Michel Pierron à télécharger sur excelabo.
(page téléchargement : mp-menuuserform.zip ou qq chose comme ça)

Misange migrateuse http://www.excelabo.net
mail : http://cerbermail.com/?k5Q8Dh2mta

le 20/11/2003 12:08:

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

Bonjour msillienne
Voici un exemple (à adapter) ci-dessous.
Cordialement
Pascal

1°) Dans le code de ton UserForm :
'Initialisation = création du menu popup
Private Sub UserForm_Initialize()
CreerMenu
End Sub
'Sur clic souris
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then ' le bouton droit a été appuyé
AfficheMenu
End If
End Sub
2°) Dans un module
'Création du menu
Sub CreerMenu()
Dim cb As CommandBar
Set cb = Application.CommandBars.Add("MenuSpeUsF", msoBarPopup, False,
True)
With cb
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Macro1"
.Caption = "Menu 1"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Macro2"
.Caption = "Menu 2"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Macro3"
.Caption = "Menu 3"
End With
End With
Set cb = Nothing
End Sub
' pour afficher le menu sur clic droit dans le UsF
Sub AfficheMenu()
Application.CommandBars(("MenuSpeUsF").ShowPopup
End Sub



"msillienne" <msillienne@plusdespamjenaimarre.com> a écrit dans le message
de news:0ce501c3af64$57a57f00$a101280a@phx.gbl...
ben en fait j'ai un use form qui ce lance au démarrage et
pour l'instant il y a des bouton qui permet de faire
plusieur chose mais c'est pas éstétique alors j'ai penser
au menu c'est plus bo :-) comme ca j'aurais un menus du
style : Fichier Edition MenuPerso etc...
mais si y a plus simple je prend
merci

merçi c'est kool et ca marche

-----Message d'origine-----
Bonjour,
Tu trouveras un exemple de Michel Pierron à télécharger
sur excelabo.

(page téléchargement : mp-menuuserform.zip ou qq chose
comme ça)

Misange migrateuse http://www.excelabo.net
mail : http://cerbermail.com/?k5Q8Dh2mta

le 20/11/2003 12:08:

bonjour
j'ai bo chercher mais je trouve pas ici et labas
je souhaiterais faire un menu dans un userform
mais je sais pas du tout faire et pas de doc
pouvez vous me helper please
merci

.

Maudite paresse. Un petit effort pour écrire autre chose que du
charabia ne serait pas de refus.




"msillienne" <msillienne@plusdespamjenaimarre.com> a écrit dans le
message de news:0ce501c3af64$57a57f00$a101280a@phx.gbl...
ben en fait j'ai un use form qui ce lance au démarrage et
pour l'instant il y a des bouton qui permet de faire
plusieur chose mais c'est pas éstétique alors j'ai penser
au menu c'est plus bo :-) comme ca j'aurais un menus du
style : Fichier Edition MenuPerso etc...
mais si y a plus simple je prend
merci