Context menu item does not call subroutine?

Hello,

I have found this article that explains how to create a context menu when one right clicks a cell:

http://sitestory.dk/excel_vba/popup-menu-eng.htm

So I attempted to do just one item and here is what I entered in VBA:

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''SMALL
Sub Auto_Open()
   CreateShortcut
End Sub

Private Sub Worksheet_BeforeRightClick _
(ByVal Target As Excel.Range, Cancel As Boolean)

Dim rIsect As Range

On Error GoTo ErrorHandle

Set rIsect = Application.Intersect(Range("E4:E8"), Target)

If Not rIsect Is Nothing Then
   CommandBars("MyShortcut").ShowPopup
   Cancel = True
End If

BeforeExit:
Set rIsect = Nothing

Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub


Sub CreateShortcut()
Dim myBar As CommandBar
Dim myItem As CommandBarControl

On Error Resume Next

'Deletes any old popup menu.
CommandBars("MyShortcut").Delete

On Error GoTo ErrorHandle


Set myBar = CommandBars.Add _
   (Name:="MyShortcut", Position:=msoBarPopup, Temporary:=True)


Set myItem = myBar.Controls.Add(Type:=msoControlButton)
With myItem
   .Caption = "&Menu item 1..."
   .OnAction = "Dummy1"
   .FaceId = 133
End With

Exit Sub
ErrorHandle:
MsgBox Err.Description & vbNewLine & _
"Procedure CreateShortcut.", vbCritical, "Error"
End Sub


Sub Dummy1()
MsgBox "Menu item 1"
End Sub

Although the context menu appears, it appears with 7 items instead of one and when I click on the menu item, the dummy function does not get called???

Does anyone know what I am doing wrong?

Thanks all for your help
Rn