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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
| '#################################################
'#################################################
Public Sub MenuPerformanceSport() 'Procédure principale de création du menu
Dim rstMenu As DAO.Recordset
Dim strSQLMenu As String
Dim strTag As String
Dim strTagParent As String
Dim strNomCommandBar As String
Dim strNomEntete As String
Dim strCaption As String
Dim objCommandBar As Office.CommandBar
Dim objCommandBarComboBox As Office.CommandBarComboBox
Dim strGenre As String
Dim lMonRepère As Long
Dim lFaceId As Long
Dim strInfoBull As String
Dim strSpecific As String
strNomCommandBar = "MenuSports"
Call SuppMenu(strNomCommandBar)
Set objCommandBar = Application.CommandBars.Add(strNomCommandBar, , True)
objCommandBar.Visible = True
strSQLMenu = "Select * From tMenu ORDER BY MonRepère "
Set rstMenu = CurrentDb.OpenRecordset(strSQLMenu, dbOpenDynaset)
rstMenu.MoveFirst
While Not rstMenu.EOF
strInfoBull = CStr(Nz(rstMenu("InfoBull"), "Vide"))
strSpecific = CStr(Nz(rstMenu("Spécifique"), "Non"))
lFaceId = CLng(IIf(Not IsNull(rstMenu("IconBtn")), rstMenu("IconBtn"), 0))
strGenre = CStr(IIf(Not IsNull(rstMenu("Action")), "Btn", "Pop"))
strTag = rstMenu("MenuID")
strCaption = rstMenu("Nom")
Select Case rstMenu("Parent")
Case "Top"
strNomEntete = rstMenu("Nom")
'Appeler création entete menu
Call AjoutEnteteMenuPerfSport(strNomCommandBar, strNomEntete, strTag)
Case Else
'c'est un sous menu
strTagParent = rstMenu("Parent")
Call AjoutSousMenuPerfSport(strTag, strCaption, strTagParent, strGenre, lFaceId, strInfoBull, strSpecific)
End Select
rstMenu.MoveNext
Wend
' Ajouter en fin de menu la combo pour Objectif ou Réalisation
Set objCommandBarComboBox = objCommandBar.Controls.Add(msoControlComboBox)
With objCommandBarComboBox
.AddItem "Réalisation"
.AddItem "Objectif"
'.Text = "Catégorie"
.Style = msoComboNormal
.TooltipText = "Sélectionner la catégorie des Données et des Résultats"
.ListIndex = 1 'ie Réalisation par défaut
.OnAction = "Estomper"
End With
rstMenu.Close
Set rstMenu = Nothing
End Sub
'#################################################
'#################################################
Public Sub AjoutEnteteMenuPerfSport(strNomCommandBar As String, strNomEntete As String, strTag As String)
Dim objCommandBarControl As Office.CommandBarControl
Dim objCommandBarPopup As Office.CommandBarPopup
Set objCommandBarPopup = Application.CommandBars(strNomCommandBar).Controls.Add(msoControlPopup)
With objCommandBarPopup
.Caption = strNomEntete
'.Style = msoButtonCaption
.Tag = strTag
End With
'#################################################
'#################################################
Public Sub AjoutSousMenuPerfSport(strTag As String, strCaption As String, strTagParent As String, strGenre As String, lFaceId As Long, strInfoBull As String, strSpecific As String)
On Error GoTo List_Err
Dim objCommandBarControl As Office.CommandBarControl
Dim objCommandBarPopup As Office.CommandBarPopup
Dim objCommandBarPopup2 As Office.CommandBarPopup
Set objCommandBarPopup = Application.CommandBars.FindControl(msoControlPopup, , Tag:=strTagParent) ', Visible:=False, Recursive:=True)
Select Case strGenre
Case "Pop"
Set objCommandBarPopup2 = objCommandBarPopup.Controls.Add(msoControlPopup)
objCommandBarPopup2.Caption = strCaption
objCommandBarPopup2.Tag = strTag
Case "Btn"
Set objCommandBarControl = objCommandBarPopup.Controls.Add(msoControlButton)
objCommandBarControl.Style = msoButtonIconAndCaption
objCommandBarControl.Caption = strCaption
objCommandBarControl.Tag = strTag
objCommandBarControl.FaceId = lFaceId
If strInfoBull <> "Vide" Then objCommandBarControl.TooltipText = strInfoBull
'La TooltipText ne fonctionne pas ?????
objCommandBarControl.Parameter = strSpecific
objCommandBarControl.OnAction = "=ActionBtnMenu (" & Chr(34) & strTag & Chr(34) & ")"
objCommandBarControl.Visible = True
End Select
ListBouton_Fin:
Exit Sub
List_Err:
MsgBox "Erreur " & Err.Number & ": " & Err.Description
Resume ListBouton_Fin
End Sub
'#################################################
'#################################################
Public Function ActionBtnMenu(strTag As String)
Select Case strTag
Case "A4", "C100", "I3", "H4", "E6", "F6", "D4", "B4", "G8"
MsgBox "Quitter application"
Case Else
MsgBox "Faire autre chose avec le bouton : " & strTag
End Select
End Function
'#################################################
'#################################################
Public Sub Estomper()
Dim objCommandBar As Office.CommandBar
Dim btn As Office.CommandBarControl
Dim btnCombo As CommandBarComboBox
Dim strCatComboBox As String
Dim strCat As String
Dim strNomCommandBar As String
strNomCommandBar = "MenuSports"
Set btnCombo = CommandBars("MenuSports").FindControl(msoControlComboBox)
strCatComboBox = btnCombo.List(btnCombo.ListIndex)
Select Case strCatComboBox
Case "Objectif"
For Each btn In Application.CommandBars.Item("MenuSports").Controls
If btn.Type = msoControlButton Then
If btn.Parameter = "O" Then btn.Enabled = True
If btn.Parameter = "R" Then btn.Enabled = False
End If
Next btn
Case "Réalisation"
For Each btn In CommandBars("MenuSports").Controls
If btn.Type = msoControlButton Then
If btn.Parameter = "O" Then btn.Enabled = False
If btn.Parameter = "R" Then btn.Enabled = True
End If
Next btn
End Select
End Sub
'#################################################
'#################################################
Private Sub Quitter()
'DoCmd.Quit
MsgBox "Quitter application"
End Sub
'#################################################
'#################################################
Public Sub SuppMenu(strNomCommandBar As String)
Dim objCommandBar As Office.CommandBar
For Each objCommandBar In Application.CommandBars
If objCommandBar.Name = strNomCommandBar Then
objCommandBar.Delete
End If
Next objCommandBar
End Sub |
