Custom menu shows multiple times

[moonshadow91]

Hi,

I have developed some macros which help daily tasks in our office. They are saved in .xlam file. When the file is open, it creates right click menu. Everything worked fine with office 2010. Now we upgraded to office 2013 and office 2016. All macros work fine, but I have a problem with the right click menu - it appears multiple times (see screenshot below).

Here is the code for the custom menu:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next

DeleteTheMenu
End Sub
 
Private Sub Workbook_Open()
On Error Resume Next

MakeTheMenu

End Sub

Option Explicit
Sub MakeTheMenu()
 
    On Error Resume Next
    Application.ScreenUpdating = False
    DeleteTheMenu
    Dim myBar As Object, myMenuItem As CommandBarControl
   Dim RowNo As Long, MenuRowNo As Long
    Dim CmdBar As CommandBar
   
    RowNo = 4
    Select Case ThisWorkbook.Sheets("Menu").Range("B2").Value
       
    Case "Right-Click Menu"
    For Each CmdBar In Application.CommandBars
    If CmdBar.Name = "Cell" Then
        Debug.Print CmdBar.Index
        Set myBar = Application.CommandBars(CmdBar.Index).Controls.Add(Type:=msoControlPopup)
        With myBar
            .Caption = ThisWorkbook.Sheets("Menu").Range("B1").Value
            .Tag = ThisWorkbook.Sheets("Menu").Range("B1").Value
            .BeginGroup = True
        End With
        RowNo = 4
        MenuRowNo = 0
        GoSub fill
    End If
    Next
 
Application.ScreenUpdating = True
Exit Sub
fill:
    Do While ThisWorkbook.Sheets("Menu").Cells(RowNo, 1).Value <> ""
        Select Case ThisWorkbook.Sheets("Menu").Cells(RowNo, 1).Value
        Case 1
            Set myMenuItem = myBar.Controls.Add(msoControlPopup)
            With myMenuItem
                .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2)
            End With
            MenuRowNo = 0
        Case 2
            With myMenuItem.Controls.Add(Type:=msoControlButton)
                If MenuRowNo < 10 Then
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                Else
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                End If
                .OnAction = ThisWorkbook.Sheets("Menu").Cells(RowNo, 3).Value
                .BeginGroup = ThisWorkbook.Sheets("Menu").Cells(RowNo, 4).Value
                .FaceId = ThisWorkbook.Sheets("Menu").Cells(RowNo, 5).Value
            End With
        Case 3
            With myBar.Controls.Add(Type:=msoControlButton)
                If MenuRowNo < 10 Then
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                Else
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                End If
                .OnAction = ThisWorkbook.Sheets("Menu").Cells(RowNo, 3).Value
                .BeginGroup = ThisWorkbook.Sheets("Menu").Cells(RowNo, 4).Value
                .FaceId = ThisWorkbook.Sheets("Menu").Cells(RowNo, 5).Value
            End With
        End Select
        RowNo = RowNo + 1
        MenuRowNo = MenuRowNo + 1
    Loop
    Return
 
End Sub
Sub DeleteTheMenu()
    On Error Resume Next
    CommandBars.FindControl(Tag:=ThisWorkbook.Sheets("Menu").Range("B1").Value).Delete
    CommandBars(ThisWorkbook.Sheets("Menu").Range("B1").Value).Delete
End Sub

I also noticed it does not happen with all files – for some there is only 1 menu, for other 3,4 and etc…

Thank you very much in advance!

 

[lhartono]

You forgot to delete one of the control.

Suggestion:

Sub MakeTheMenuNew()
 
    On Error Resume Next
    
    [COLOR=#ff0000]Const myTag = "Utilities by moonshadow91"[/COLOR]
    
    Dim myBar As Object, myMenuItem As CommandBarControl
    Dim RowNo As Long, MenuRowNo As Long
    Dim cmdBar As CommandBar
   
    Application.ScreenUpdating = False
    DeleteTheMenuNew
  
    RowNo = 4
    Select Case ThisWorkbook.Sheets("Menu").Range("B2").Value
       
    Case "Right-Click Menu"
    For Each cmdBar In Application.CommandBars
    Debug.Print cmdBar.Name
    If cmdBar.Name = "Cell" Then
        Debug.Print cmdBar.Index
        Set myBar = Application.CommandBars(cmdBar.Index).Controls.Add(Type:=msoControlPopup)
        With myBar
            .Caption = ThisWorkbook.Sheets("Menu").Range("B1").Value
            [COLOR=#ff0000].Tag = myTag[/COLOR]
            .BeginGroup = True
        End With
        RowNo = 4
        MenuRowNo = 0
        GoSub fill
    End If
    Next
    End Select
Application.ScreenUpdating = True
Exit Sub
fill:
    Do While ThisWorkbook.Sheets("Menu").Cells(RowNo, 1).Value <> ""
        Select Case ThisWorkbook.Sheets("Menu").Cells(RowNo, 1).Value
        Case 1
            Set myMenuItem = myBar.Controls.Add(msoControlPopup)
            With myMenuItem
                .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2)
                [COLOR=#ff0000].Tag = myTag[/COLOR]
            End With
            MenuRowNo = 0
        Case 2
            With myMenuItem.Controls.Add(Type:=msoControlButton)
                If MenuRowNo < 10 Then
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                    [COLOR=#ff0000].Tag = myTag[/COLOR]
                Else
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                    [COLOR=#ff0000].Tag = myTag[/COLOR]
                End If
                .OnAction = ThisWorkbook.Sheets("Menu").Cells(RowNo, 3).Value
                .BeginGroup = ThisWorkbook.Sheets("Menu").Cells(RowNo, 4).Value
                .FaceId = ThisWorkbook.Sheets("Menu").Cells(RowNo, 5).Value
            End With
        Case 3
            With myBar.Controls.Add(Type:=msoControlButton)
                If MenuRowNo < 10 Then
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                    [COLOR=#ff0000].Tag = myTag[/COLOR]
                Else
                    .Caption = ThisWorkbook.Sheets("Menu").Cells(RowNo, 2).Value
                    [COLOR=#ff0000].Tag = myTag[/COLOR]
                End If
                .OnAction = ThisWorkbook.Sheets("Menu").Cells(RowNo, 3).Value
                .BeginGroup = ThisWorkbook.Sheets("Menu").Cells(RowNo, 4).Value
                .FaceId = ThisWorkbook.Sheets("Menu").Cells(RowNo, 5).Value
            End With
        End Select
        RowNo = RowNo + 1
        MenuRowNo = MenuRowNo + 1
    Loop
    Return
 
End Sub

Sub DeleteTheMenuNew()
    [COLOR=#ff0000]Const myTag = "Utilities by moonshadow91"[/COLOR]
    CommandBars.FindControl(Type:=MsoControlType.msoControlButton, Tag:=myTag).Delete
    CommandBars.FindControl(Type:=MsoControlType.msoControlPopup, Tag:=myTag).Delete
End Sub

'or you can use this, maybe a bit slower

Sub DeleteTheMenuAll()
    Dim cmdBar As CommandBar
    Dim cmdBars As CommandBars
    Dim cmdBC As CommandBarControl
    
    [COLOR=#ff0000]Const myTag = "Utilities by moonshadow91"[/COLOR]
    
    For Each cmdBar In Application.CommandBars
        For Each cmdBC In cmdBar.Controls
            If cmdBC.Tag = [COLOR=#ff0000]myTag[/COLOR] Then
                cmdBC.Delete
            End If
        Next
    Next
End Sub