Bonjour,
Voila la Situation :
Je travaille sur ACCESS 2003.
J’inclus manuellement le fichier MSO.DLL ; pour mon PC, il se trouve dans C:\Program Files\Fichiers communs\Microsoft Shared\OFFICE11
Je crée un menu dynamique à partir d’un recordset basé sur une table.
Les menus, sous menu et boutons s’affichent selon la logique que j’ai établi.
 
Voila les problèmes :
1) J’éteint mon poste, je redémarre et les boutons (msoControlButton) du menu n’apparaissent plus. Je ré inclus le fichier MSO.DLL et rien ne marche plus !!!!!!!.  
2) je crée une nouvelle BD, j’y importe le module et la table en question, je ré inclus le fichier MSO.DLL et ça marche !!!!!!!.
3) Les menus apparaissent relativement lentement, y’a t il moyen d’accélérer cette opération ?
4) je n’arrive pas à contrôler la propriété Enabled selon l’item de la Combo.
5) je n’arrive pas à afficher les TooltipText, pourtant, son texte est bien transmis à la procédure.
6) la fonction FindControl n’accepte pas le paramètre Recursive
 
C’est beaucoup tout cela, non ???.
 
Merci.
 
En tout cas, voici l’affreux code :
 
Code :
[VBA]
 
'#################################################
'#################################################
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