' Macros de JCGL
Sub CréerMenu()
Dim FeuilleMenus As Worksheet
Dim MenuDéroulant As CommandBarPopup
Dim SousMenu As Object
Dim SousMenuMacro As CommandBarButton
Dim Ligne As Integer
Dim NiveauDeMenu, NiveauSuivant, PositionOuMacro, TexteMenu, Séparation, IconeMenu
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Localisation des données des Menus
Set FeuilleMenus = ThisWorkbook.Sheets("PourMenus")
''''''''''''''''''''''''''''''''''''''''''''''''''''
' S'assure que le menu n'existe pas
Call EffacerMenu
' Initialise le Ligne
Ligne = 2
' Ajoute les menus, sous menus et routines
' se trouvant dans FeuilleMenus
Do Until IsEmpty(FeuilleMenus.Cells(Ligne, 1))
With FeuilleMenus
NiveauDeMenu = .Cells(Ligne, 1)
TexteMenu = .Cells(Ligne, 2)
PositionOuMacro = .Cells(Ligne, 3)
Séparation = .Cells(Ligne, 4)
IconeMenu = .Cells(Ligne, 5)
NiveauSuivant = .Cells(Ligne + 1, 1)
End With
Select Case NiveauDeMenu
Case 1 ' 1 Menu
' Additionne le menu
Set MenuDéroulant = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
Before:=PositionOuMacro, _
temporary:=True)
MenuDéroulant.Caption = TexteMenu
Case 2 ' 1 un sous menu
If NiveauSuivant = 3 Then ' Si sous sous menu
Set SousMenu = MenuDéroulant.Controls.Add(Type:=msoControlPopup)
Else
Set SousMenu = MenuDéroulant.Controls.Add(Type:=msoControlButton)
SousMenu.OnAction = PositionOuMacro
End If
SousMenu.Caption = TexteMenu
If IconeMenu <> "" Then SousMenu.FaceId = IconeMenu
If Séparation Then SousMenu.BeginGroup = True
Case 3 ' 1 sous sous menu
Set SousMenuMacro = SousMenu.Controls.Add(Type:=msoControlButton)
SousMenuMacro.Caption = TexteMenu
SousMenuMacro.OnAction = PositionOuMacro
If IconeMenu <> "" Then SousMenuMacro.FaceId = IconeMenu
If Séparation Then SousMenuMacro.BeginGroup = True
End Select
Ligne = Ligne + 1
Loop
End Sub
Sub EffacerMenu()
' Efface Le menu
Dim FeuilleMenus As Worksheet
Dim Ligne As Integer
Dim TexteMenu As String
On Error Resume Next
Set FeuilleMenus = ThisWorkbook.Sheets("PourMenus")
Ligne = 2
Do Until IsEmpty(FeuilleMenus.Cells(Ligne, 1))
If FeuilleMenus.Cells(Ligne, 1) = 1 Then
TexteMenu = FeuilleMenus.Cells(Ligne, 2)
Application.CommandBars(1).Controls(TexteMenu).Delete
End If
Ligne = Ligne + 1
Loop
On Error GoTo 0
End Sub