PopUp Menu Demo

Demonstrates how to create and implement a popup menu.

Here is a link to the demonstration file which contains all the code described on this page: PopUpMenuDemo

The code is in one VBA module: PopUpMenu
and in the following worksheet module: WorksHere

PopUpMenu Code

The in-line comments describe the action, but the one to remember is "RunMeToGetThingsGoing" otherwise nothing happens. Now switch to the "WorksHere" sheet and right click on any cell. There are two options on the popup menu; both run the same macro which displays a message.

Option Explicit

Public Const gc_Title = "PopUp Menu Demo"
Public gcBar_RgtClkMenu As CommandBar

'' ***************************************************************************
'' Purpose  : Runs routines to create our popup menu
'' Written  : 18-Jul-2001 by Andy Wiggins, Byg Software Limited
''
Sub RunMeToGetThingsGoing()
    Set gcBar_RgtClkMenu = CreateSubMenu
End Sub

'' ***************************************************************************
'' Purpose  : Demo
'' Written  : 18-Jul-2001 by Andy Wiggins, Byg Software Limited
''
Function CreateSubMenu() As CommandBar

''Name for popup menu
Const lcon_PuName = "PopUpDemo"

''Create some objects
Dim cb As CommandBar
Dim cbc As CommandBarControl

    ''Ensure our popup menu does not exist
     
     DeleteCommandBar lcon_PuName

    ''Add our popup menu to the CommandBars collection
    Set cb = CommandBars.Add(Name:=lcon_PuName, Position:=msoBarPopup, MenuBar:=False, Temporary:=False)

    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    '' Add some demo controls
    Set cbc = cb.Controls.Add
    With cbc
        .Caption = "&Control 1"
        .OnAction = "DummyMessage"
    End With

    Set cbc = cb.Controls.Add
    With cbc
        .Caption = "Control &2"
        .OnAction = "DummyMessage"
    End With
    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    
    Set CreateSubMenu = cb

End Function

'' ***************************************************************************
'' Purpose  : Delete a named command bar
''          : Cycle through all existing names - if our one exists, delete it
'' Written  : 27-Mar-2001 by Andy Wiggins, Byg Software Limited
''
Sub DeleteCommandBar(menuName)
Dim mb
    For Each mb In CommandBars
        If mb.Name = menuName Then
            CommandBars(menuName).Delete
        End If
    Next
End Sub

Sub DummyMessage()
    MsgBox "Hello", vbInformation + vbOKOnly, gc_Title
End Sub

WorksHere Code

These routines test whether the PopUp menu exists. If it doesn't you are asked whether you want to run the macro that gets it all going.

Option Explicit

'' ***************************************************************************
'' Purpose  : Initiated by user's right click
'' Written  : 18-Jul-2001 by Andy Wiggins, Byg Software Limited
''
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    
On Error GoTo Worksheet_BeforeRightClick_Error

    ''Show our custom popup
    gcBar_RgtClkMenu.ShowPopup
    
Worksheet_BeforeRightClick_Resume:
    ''This needs to be set as TRUE to stop the default popup menu from showing
    Cancel = True
    ''All done, so leave the procedure
    Exit Sub

Worksheet_BeforeRightClick_Error:
    ''Only get here if the initiation macro hasn't been run
    ''Ask the user if it's to be run now
    If vbYes = MsgBox("You need to run the macro ""RunMeToGetThingsGoing"" before this demo will work" _
                    & vbCrLf & vbCrLf & "Run it now?", vbQuestion + vbYesNo, gc_Title) Then
        ''User clicked "Yes", so run it
        RunMeToGetThingsGoing
        MsgBox "Now try again", vbInformation + vbOKOnly, gc_Title
    End If

    ''Tidy up and leave
    Resume Worksheet_BeforeRightClick_Resume
    
End Sub