VBA EXCEL - GESTION DE MENUS CONTEXTUELS (CLIC-DROIT) PRÊTE À L'EMPLOI ET FACILE À PARAMÈTRER

'==============================================
' Dans le module MenusContextuels
'==============================================
Option Explicit
Public mcMenusOuiNon As Boolean
Public Const mcDébutNom = "mc"
Public Const mcCommun = "mcCommun"
Public Const mcStandard = "mcStandard"
Public Const mcPlageMenus = "mcMenus"
Public Const mcPlageFeuilles = "mcFeuilles"
Public Const mcNomFeuilleMenus = "mcMenusContextuels"

' Procédure de création des menus contextuels temporaires
' cette procedure est appelée à l'ouverture du classeur
' (Cf la Procedure WorkBook_Open du module de classe ThisWorkBook)
Sub mcCreationMenus()
    'On Error GoTo Erreur
    Dim B As CommandBar
    Dim C As CommandBarControl
    Dim L As Single
    Dim n As String
    ' suppression de toutes les barres contextuelles mc
    For Each B In Application.CommandBars
        If Left(B.Name, Len(mcDébutNom)) = mcDébutNom And B.Position = msoBarPopup Then
            B.Delete
        End If
    Next B
    ' Ajout des barres de menu contextuel figurant dans la plage mcMenus
    ' le nom est dans la première colonne de la plage
    ' Position:=msoBarPopup indique qu'il s'agit d'un menu contextuel
    With Range(mcPlageMenus)
        ' on lit toutes les lignes de la plage
        n = ""
        For L = 1 To .Rows.Count
            ' s'il s'agit d'un nouveau menu
            If Not IsEmpty(.Cells(L, 1)) Then
                ' on vérifie si le nom du menu est correct
                ' (sauf si on est sur la dernière ligne de la plage)
                If L <> .Rows.Count And (Left(.Cells(L, 1), Len(mcDébutNom)) <> mcDébutNom Or _
                    InStr(1, .Cells(L, 1), " ") > 0) Then
                    MsgBox "Vérifier les noms des menus SVP"
                    Exit Sub
                End If
                ' s'il ne s'agit pas du menu mcCommun
                ' on ajoute les options de ce dernier au menu précédent
                ' avant d'en créer un nouveau
                If n <> "" And n <> mcCommun Then mcAjouteOptionsCommun n
                ' la dernière ligne de la plage n'est pas un menu
                If L = .Rows.Count Then Exit Sub
                ' on crée le nouveau menu
                n = .Cells(L, 1)
                Set B = Application.CommandBars.Add(Name:=n, Position:=msoBarPopup, Temporary:=True)
            End If
            ' on ajoute une option de menu
            Set C = B.Controls.Add
                ' on définit ses propriétés
                C.Tag = .Cells(L, 2)        ' Définit la référence interne du contrôle qui
                                            ' peut être utilisé ensuite avec la méthode FindControl
                C.Caption = .Cells(L, 3)    ' Définit le texte du menu (3ème colonne de la plage)
                C.OnAction = .Cells(L, 4)   ' Définit la procédure liée (4ème colonne de la plage)
                C.BeginGroup = .Cells(L, 5) ' Indique si cette option est le début d'un groupe
                                            ' (présence d'un trait de séparation avec l'option
                                            '  précédente)
                C.Enabled = .Cells(L, 6)    ' Active ou désactive l'option à la création
        Next L
    End With
    Exit Sub
Erreur:
    MsgBox Err.Description & " (" & Err.Number & ") dans mcCréationMenus"
End Sub

Sub mcDésactiveMenus()
    ' Procédure (appelée par une option des menus contextuels) qui désactive
    ' l'usage des menus. Les menus contextuels standards d'Excel redeviennent actifs
    ' En réalité, c'est la procédure évènementièle Workbook_SheetBeforeRightClick
    ' qui va tester la variable globale mcMenusOuiNon pour savoir si elle intercepte de clic-droit
    ' ou si elle laisse faire Excel
    mcMenusOuiNon = False
End Sub
Sub mcActiveMenus()
    ' Appel de la procedure de création du menu contextuel
    ' Cette procédure est appelée par les touches : Ctrl-m
    ' (elle ne peut pas être appelée par une option de menu car ce dernier est désactivé)
    ' Elle recrée le système de menus et positionne l'indicateur d'activité à Vrai
    mcCreationMenus
    mcMenusOuiNon = True
End Sub

Sub mcAjouteOptionsCommun(NomMenu As String)
    ' Cette procédure permet d'ajouter à la fin de tous les menus
    ' les options du menu mcCommun
    ' Appelée par la procédure mcCréationMenus
    On Error GoTo Erreur
    ' Barre de menu mcCommun et ses controles
    Dim BSource As CommandBar
    Dim CSource As CommandBarControl
    Set BSource = Application.CommandBars(mcCommun)
    ' La barre de menu nouvellement créée à laquelle on veut ajouter
    ' les options de mcCommnun
    ' Son nom est fourni par la procédure appelante (ici mcCréationMenus)
    Dim BDest As CommandBar
    Dim CDest As CommandBarControl
    Set BDest = Application.CommandBars(NomMenu)
    ' Pour chaque contrôle de mcCommun
    ' on ajoute un contrôle à la nouvelle barre avec les mêmes propriétés
    For Each CSource In BSource.Controls
        Set CDest = BDest.Controls.Add          ' ajout du contrôle
        CDest.Caption = CSource.Caption         ' récupération du texte (légende)
        CDest.OnAction = CSource.OnAction       ' récupération de l'action associée
        CDest.BeginGroup = True                 ' Les options communes commencent toujours
                                                ' un nouveau groupe
        CDest.Tag = CSource.Tag                 ' récupération du Tag (identification interne)
    Next CSource
    Exit Sub
Erreur:
    MsgBox Err.Description & " (" & Err.Number & ") dans mcAjouteOptionsCommun"
End Sub

Sub mcAfficheMasqueFeuilleMenus()
    ' Cette procédure inverse la propriété de visibilité de la feuille Excel
    ' qui contient les éléments des menus
    With Sheets(mcNomFeuilleMenus)
        .Visible = Not .Visible
        ' après affichage, la feuille des menu est sélectionnée
        If .Visible Then .Select
    End With
End Sub

'===========================================================
' Dans ThisWorkbook
'===========================================================
Option Explicit

Private Sub Workbook_Open()
    mcActiveMenus
End Sub

' Lorsque l'utilisateur utilise le bouton droit de la souris
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error GoTo Erreur
    Dim L As Integer
    Dim n As String
    ' Si Menu Contextuel non activé
    ' on sort de la procédure et
    ' le bouton droit de la souris garde son role habituel
    If Not mcMenusOuiNon Then Exit Sub
    ' si la feuille appelante figure dans la plage mcFeuilles
    ' on affiche le menu correspondant
    'sinon on affiche le menu mcStandard
    With Range(mcPlageFeuilles)
        n = mcStandard
        For L = 1 To .Rows.Count
            If .Cells(L, 1) = Sh.Name Then
                n = .Cells(L, 2)
                Exit For
            End If
        Next L
    End With
    Application.CommandBars(n).ShowPopup
    ' On annule l'affichage du menu contextuel par défaut
    Cancel = True
    Exit Sub
Erreur:
        MsgBox Err.Description & " (" & Err.Number & ") dans le BeforeRightClick"
End Sub

'============================================
' Dans un module : Quelques exemples d'accès aux menus
'============================================
Option Explicit

Function mcExemple()
    ' Quelques exemples d'accès aux contrôles des menus
    
    ' Pour déactiver le contrôle n du menu mcMachin
    Dim n As Integer
    CommandBars("mcMachin").Controls(n).Enabled = False
    
    ' Pour masquer le contrôle de Tag mcTruc dans le menu mcMachin
    CommandBars("mcMachin").FindControl(Tag:="mcTruc").Visible = False
    
    ' Pour désactiver tous les contrôles du menu mcMachin
    Dim C As CommandBarControl
    For Each C In CommandBars("mcMachin")
        C.Enabled = False
    Next C
    ' ou
    With CommandBars("mcMachin")
        For n = 1 To .Controls.Count
            .Controls(n).Enabled = False
        Next n
    End With
End Function

Télécharger le zip

28 septembre 2007 15:36:01 :

Ajout de la gestion de plusieurs menus, affectation de menus à des feuilles, fourniture d'un modèle prêt à l'emploi

28 septembre 2007 15:37:28 :

Ajout de la gestion de plusieurs menus, affectation de menus à des feuilles, fourniture d'un modèle prêt à l'emploi

28 septembre 2007 15:45:08 :

Modification de la capture

28 septembre 2007 15:45:47 :

Modification de la capture

28 septembre 2007 15:47:46 :

Modification capture

05 décembre 2008 08:06:51 :

Nouveau Zip : Amélioration des classeurs