How to Add a pop up menus with multiple menus levels

Well as the title says, what i need is to make a pop menu in a sheet and I found a some solution (shown at the bottom) but I need to at least 4 level menus (sorry for my terrible english), and if its posible an action on all of the menus of eache level, just like in the code at the bottom, but with 4 or 5 levels. Thans in advance for your help.

Option Explicit

Public Const Mname As String = "MyPopUpMenu"

Sub DeletePopUpMenu()
    'Delete PopUp menu if it exist
    On Error Resume Next
    Application.CommandBars(Mname).Delete
    On Error GoTo 0
End Sub

Sub CreateDisplayPopUpMenu()
    'Delete PopUp menu if it exist
    Call DeletePopUpMenu

    'Create the PopUpmenu
    Call Custom_PopUpMenu_1

    'Show the PopUp menu
    On Error Resume Next
    Application.CommandBars(Mname).ShowPopup
    On Error GoTo 0
End Sub


Sub Custom_PopUpMenu_1()
    Dim MenuItem As CommandBarPopup
    'Add PopUp menu
    With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
                                     MenuBar:=False, Temporary:=True)

        'First add two buttons
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "Button 1"
            .FaceId = 71
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Caption = "Button 2"
            .FaceId = 72
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
        End With

        'Second Add menu with two buttons
        Set MenuItem = .Controls.Add(Type:=msoControlPopup)
        With MenuItem
            .Caption = "My Special Menu"

            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Button 1 in menu"
                .FaceId = 71
                .OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
            End With

            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Button 2 in menu"
                .FaceId = 72
                .OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
            End With
        End With

        'Third add one button
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "Button 3"
            .FaceId = 73
            .OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
        End With

    End With
End Sub


Sub TestMacro()
    MsgBox "Hi There, greetings from the Netherlands"
End Sub