1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
Private Const MF_CHECKED = &H8&
Private Const MF_APPEND = &H100&
Private Const TPM_LEFTALIGN = &H0&
Private Const MF_DISABLED = &H2&
Private Const MF_GRAYED = &H1&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Const TPM_RIGHTBUTTON = &H2&
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, _
ByVal Y As Long, ByVal HWnd As Long, ByVal lptpm As Any) As Long
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal HWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function AppendMenu Lib "user32" Alias _
"AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, _
ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" _
(ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Public Function MenuContextuel_Etat()
Dim Pt As POINTAPI
Dim result As Long
Dim hMenu As Long
Dim TypeMenu1 As Long
Dim TypeMenu2 As Long
Dim TypeMenu3 As Long
Dim TypeMenu4 As Long
Dim TypeMenu5 As Long
Dim TypeMenu6 As Long
Dim TypeMenu7 As Long
Dim TypeMenu8 As Long
Dim TypeMenu9 As Long
Dim TypeMenu10 As Long
Dim TypeMenu11 As Long
Dim TypeMenu12 As Long
TypeMenu1 = MF_STRING
TypeMenu2 = MF_STRING
TypeMenu3 = MF_STRING
TypeMenu4 = MF_STRING
TypeMenu5 = MF_STRING
TypeMenu6 = MF_STRING
TypeMenu7 = MF_STRING
TypeMenu8 = MF_STRING
TypeMenu9 = MF_STRING
TypeMenu10 = MF_STRING
TypeMenu11 = MF_STRING
TypeMenu12 = MF_STRING
hMenu = CreatePopupMenu()
AppendMenu hMenu, TypeMenu1, 1, "Zoom ajusté"
AppendMenu hMenu, TypeMenu2, 2, "Zoom à 10 %"
AppendMenu hMenu, TypeMenu3, 3, "Zoom à 25 %"
AppendMenu hMenu, TypeMenu4, 4, "Zoom à 50 %"
AppendMenu hMenu, TypeMenu5, 5, "Zoom à 75 %"
AppendMenu hMenu, TypeMenu6, 6, "Zoom à 100 %"
AppendMenu hMenu, TypeMenu7, 7, "Zoom à 150 %"
AppendMenu hMenu, TypeMenu8, 8, "Zoom à 200 %"
AppendMenu hMenu, MF_SEPARATOR, 9, ByVal 0&
AppendMenu hMenu, TypeMenu9, 10, "Imprimer"
AppendMenu hMenu, MF_SEPARATOR, 11, ByVal 0&
AppendMenu hMenu, TypeMenu10, 12, "Exporter dans Word"
AppendMenu hMenu, TypeMenu11, 13, "Exporter dans Exel"
AppendMenu hMenu, MF_SEPARATOR, 14, ByVal 0&
AppendMenu hMenu, TypeMenu12, 15, "Fermer"
GetCursorPos Pt
result = TrackPopupMenuEx(hMenu, _
TPM_LEFTALIGN Or TPM_RETURNCMD _
Or TPM_RIGHTBUTTON, Pt.X, Pt.Y, Screen.ActiveReport.HWnd, ByVal 0&)
DestroyMenu hMenu
Select Case result
Case 1
On Error GoTo Err
DoCmd.RunCommand acCmdFitToWindow
Case 2
On Error GoTo Err
DoCmd.RunCommand acCmdZoom10
Case 3
On Error GoTo Err
DoCmd.RunCommand acCmdZoom25
Case 4
On Error GoTo Err
DoCmd.RunCommand acCmdZoom50
Case 5
On Error GoTo Err
DoCmd.RunCommand acCmdZoom75
Case 6
On Error GoTo Err
DoCmd.RunCommand acCmdZoom100
Case 7
On Error GoTo Err
DoCmd.RunCommand acCmdZoom150
Case 8
On Error GoTo Err
DoCmd.RunCommand acCmdZoom200
Case 10
On Error GoTo Err
DoCmd.RunCommand acCmdPrint
Case 12
On Error GoTo Err
DoCmd.OutputTo acReport, Screen.ActiveReport.Name, "RichTextFormat(*.rtf)", , True, ""
Case 13
On Error GoTo Err
DoCmd.OutputTo acReport, Screen.ActiveReport.Name, "MicrosoftExcel(*.xls)", , True, ""
Case 15
On Error GoTo Err
DoCmd.Close acReport, Screen.ActiveReport.Name, acSaveYes
Err: FormattedMsgBox "Cette commande est indisponible!@Contactez le support technique de cette application.@", vbCritical, ApplicationNameApi()
End Select
End Function |
[VBA]Menu contextuel dynamique dans un état
Répondre avec citation
Envoyé par marcb03
.....le seul problème est qu'au premier "appel" du clic droit tu as systématiquement l'apparition de ce fameux petit carré de couleur, tu reclic et le menu s'affiche correctement..
.
Partager