WithEvents - same code run 2 ways: one causes crash

[Deskmanbb]

Hi,

I have a test spreadsheet with a button control array, Events attached and a right-click context menu.

Clicking a checkbox (on or off doesn't matter) will delete any buttons present, recreate the 9 buttons as part of a control array and attach events. It also creates a right-click contextmenu (it runs twice to show no problems).

Once the checkbox has been clicked at least once, you can right-click any button, select "ReDo" and the same code will run again (twice - to illustrate the problem).

Only this time it will likely crash (if it doesn't right-click on a button and select ReDo again and it surely will).

In my actual project I need to be able to right click on one or more buttons so the crashing is bad news.

Why does it crash one way (context menu) and not the other (checkbox) as the same code is running (apart from creating the contextmenu)?

It's driving me crazy! Any ideas why and how to stop it?

Test spreadsheet attached in 97~2003 format, code below.

Thanks for your help.

Code in Worksheet called "Scenario":

Option Explicit
Option Base 1

Public cbBarsContextMenu As CommandBar

Private Sub ClickMeCheckBox_Click()
Dim x As Integer
    BuildBarsRightClickMenu
    For x = 1 To 2
        RefreshButtons
    Next
End Sub

Private Sub BuildBarsRightClickMenu()
Dim cbBarButton As CommandBarButton
    On Error Resume Next
    CommandBars("MyContextMenu").Delete
    On Error GoTo 0
    Set cbBarsContextMenu = Application.CommandBars.Add(Name:="MyContextMenu", Position:=msoBarPopup, Temporary:=True)
    With cbBarsContextMenu
        Set cbBarButton = .Controls.Add(Type:=msoControlButton, Temporary:=True)
        With cbBarButton
            .FaceId = 0
            .Caption = "ReDo"
            .OnAction = ThisWorkbook.Name & "!ReDo"
        End With
    End With
End Sub

Code in module called ProjectModule:

Option Explicit
Option Base 1

Private myButtons() As OLEObject
Private mcolEvents As Collection

Private Sub ReDo()
Dim x As Integer
    For x = 1 To 2
        RefreshButtons
    Next
End Sub

Public Sub RefreshButtons()
    DeleteButtons
    AddButtons
    Application.OnTime Now(), "ProjectModule.AttachEvents"
End Sub

Private Sub DeleteButtons()
Dim OleButton As OLEObject
    Set mcolEvents = Nothing
    For Each OleButton In Worksheets("Scenario").OLEObjects
        If (TypeName(OleButton.Object) = "CommandButton") Then
            OleButton.Delete
        End If
    Next
End Sub

Private Sub AddButtons()
Dim Count As Integer
    ReDim myButtons(9) As OLEObject
    For Count = 1 To 9
        Set myButtons(Count) = Worksheets("Scenario").OLEObjects.Add("Forms.CommandButton.1")
        With myButtons(Count)
            .Top = 20 * Count
            .Height = 20
            .Left = 100
            .Width = 100
        End With
    Next Count
End Sub

Private Sub AttachEvents()
Dim ctl As OLEObject
    If (Not (mcolEvents Is Nothing)) Then
        Set mcolEvents = Nothing
    End If
    Set mcolEvents = New Collection
    For Each ctl In Worksheets("Scenario").OLEObjects
        If (TypeName(ctl.Object) = "CommandButton" And ctl.PrintObject = True) Then
            mcolEvents.Add New clsActiveXEvents
            Set mcolEvents(mcolEvents.Count).mButtons = ctl.Object
        End If
    Next
End Sub

Code in event class called clsActiveXEvents:

Option Explicit
Option Base 1
Public WithEvents mButtons As MSForms.CommandButton

Private Sub mButtons_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    If (Button = vbKeyRButton) Then
        CommandBars("MyContextMenu").ShowPopup
    Else
        MsgBox "Mouse Down!"
    End If
End Sub