Application Event in Class Module

[Guest]

I am trying to trigger a right click menu within an XLA file. My code in my
class module is as follows below. My class module is named "EventClass". I
can't seem to get the menu to trigger of the right click. The subs that get
called are in a regular module. And I currently do not have any code at all
in my ThisWorkbook module.

Thanks

Option Explicit
Public WithEvents App As Excel.Application
Public AppClass As EventClass

Private Sub Workbook_Open()
Set AppClass = New EventClass
Set AppClass.App = Excel.Application
End Sub

Private Sub App_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As
Range, Cancel As Boolean)
Call DeleteCustomMenu 'remove possible duplicates
Call BuildCustomMenu 'build new menu
End Sub

Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Call DeleteCustomMenu
End Sub

 

[Bob Phillips]

You need to separate the code.

This code goes in This Workbook (note Private AppClass not Public)

Private AppClass As EventClass

Private Sub Workbook_Open()
Set AppClass = New EventClass
Set AppClass.App = Excel.Application
End Sub

Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Call DeleteCustomMenu
End Sub

and this in the class module

Option Explicit

Public WithEvents App As Excel.Application

Private Sub App_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As
Range, Cancel As Boolean)
Call DeleteCustomMenu 'remove possible duplicates
Call BuildCustomMenu 'build new menu
End Sub



--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Guest]

That works very well Bob. Thank-you very much. Quick question for you.
This works. It creates the menu off the right click and then based on my
code, deletes it upon closing the workbook. I then tried to add a second
menu item in my BuildCustomMenu routine and also included this item in my
DeleteCustomMenu. However, the menus do not seem to delete properly. Fixing
it becomes a bit of a nightmare.

What do I need to do to have this work for more than 1 menu. Note that I
have commented out the second menu code in both the BuildCustomMenu and
DeleteCustomMenu routines.

Thanks Again for your help.

'ThisWorkBook Module
'************************************************
Private AppClass As EventClass
Private Sub Workbook_Open()
Set AppClass = New EventClass
Set AppClass.App = Excel.Application
End Sub
Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Call DeleteCustomMenu
End Sub

'Class Module
'*******************************************************
Option Explicit
Public WithEvents App As Excel.Application
Private Sub App_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As
Range, Cancel As Boolean)
Call DeleteCustomMenu 'remove possible duplicates
Call BuildCustomMenu 'build new menu
End Sub

'Regular module
'*******************************************************
Option Explicit

Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer

'add first 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=5)
ctrl.Caption = "Menu1..."
ctrl.BeginGroup = True


' 'add second 'popup' control to the cell commandbar (menu)
' Set ctrl = Application.CommandBars("Cell").Controls.Add _
' (Type:=msoControlPopup, Before:=6)
' ctrl.Caption = "Menu2"
' 'add the submenus
' Set btn = ctrl.Controls.Add
' btn.Caption = "List Correct?" 'give them a name
' btn.OnAction = "ValidationCheck" 'the routine called by the control
End Sub

Sub DeleteCustomMenu()
Dim ctrl As CommandBarControl
'go thru all the cell commandbar controls and delete our menu item
For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "Menu1..." Then ctrl.Delete
'If ctrl.Caption = "Menu2"Then ctrl.Delete
Next
End Sub

 

[Guest]

Also Bob, I slightly mispoke in the last note. The macro is building the
menus properly (if using 1 menu item), but the rest of the macro has stopped
working. That is, the action required upon selecting the desired menu item
does not occur. I didn't inlcude this code in the post. I am effectively
selecting a cell, right clicking getting menu options, click onto "Menu1",
then click onto a Button called "Copy Cell Address" and then this should
trigger a macro ("CopyRangeAddress") which copies the cell address of the
active cell to the clipboard. However when click on the menu/button, I get
an error message saying "The macro CopyRangeAddress cannot be found." Yet
its clearly a sub that is in the module.

Thanks

'ThisWorkBook
'**************************************************
Private AppClass As EventClass
Private Sub Workbook_Open()
Set AppClass = New EventClass
Set AppClass.App = Excel.Application
End Sub
Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Call DeleteCustomMenu
End Sub

'Class Module
'*************************************************
Option Explicit
Public WithEvents App As Excel.Application
Private Sub App_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As
Range, Cancel As Boolean)
Call DeleteCustomMenu 'remove possible duplicates
Call BuildCustomMenu 'build new menu
End Sub

'Regular Sub
'**************************************************
Option Explicit
Dim MyDataObj As New DataObject
Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer
'add a 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=5)
ctrl.Caption = "Menu1"
ctrl.BeginGroup = True

Set btn = ctrl.Controls.Add
btn.Caption = "Copy Cell Address" 'give them a name
btn.OnAction = "CopyRangeAddress" 'the routine called by the control

End Sub

Sub CopyRangeAddress()
Dim X As New DataObject
X.SetText Selection.Address
X.PutInClipboard
End Sub

Public Sub PutOnClipboard(Obj As Variant)
Dim MyDataObj As New DataObject
MyDataObj.SetText Format(Obj)
MyDataObj.PutInClipboard
End Sub

Sub DeleteCustomMenu()
Dim ctrl As CommandBarControl
'go thru all the cell commandbar controls and delete our menu item
For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "Menu1" Then ctrl.Delete
Next
End Sub

 

[Guest]

Found the problem regarding the sub not being found. I had another copy of
the sub in another (same sub name) module which I had forgotten about. VBA
did not know which sub to call.

Still working on the extra menu question.

Thanks

EM

 

[Bob Phillips]

This code works for me

Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer

'add first 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=5)
ctrl.Caption = "Menu1..."
ctrl.BeginGroup = True
Set btn = ctrl.Controls.Add
btn.Caption = "Copy Cell Address" 'give them a name
btn.OnAction = "CopyRangeAddress" 'the routine called by the control

'add second 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=6)
ctrl.Caption = "Menu2..."
'add the submenus
Set btn = ctrl.Controls.Add
btn.Caption = "List Correct?" 'give them a name
btn.OnAction = "ValidationCheck" 'the routine called by the control
End Sub


Sub DeleteCustomMenu()
On Error Resume Next
With Application.CommandBars("Cell")
.Controls("Menu1...").Delete
.Controls("Menu2...").Delete
End With
On Error GoTo 0
End Sub


Where did you store the macros, they should be in a standard module.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Guest]

Hi Bob. I am still having problems with this. The first time I right click,
the menu appears with my 2 new menu items. The second time I try, I get an
error message that says "Run Time Error 424. Object Required". The code
stalls on the line of code in my DeleteCustomMenu sub:

If ctrl.Caption = "Validation Check..." Then ctrl.Delete

Then when Click END and I right click again in the spreadsheet, only the
second menu item appears in the menu. Is there a problem with the way I am
using the events.

Here is all my code:

Class module
'****************************************************
Option Explicit
Public WithEvents App As Excel.Application
Private Sub App_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As
Range, Cancel As Boolean)
Call DeleteCustomMenu 'remove possible duplicates
Call BuildCustomMenu 'build new menu
End Sub

ThisWorkbook Module
'********************************************************
Private AppClass As EventClass
Private Sub Workbook_Open()
Set AppClass = New EventClass
Set AppClass.App = Excel.Application
End Sub
Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Call DeleteCustomMenu
End Sub

Regular Module
'******************************************************
Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer

'add a 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=5)
ctrl.Caption = "New Edit..."
ctrl.BeginGroup = True

'add a 'popup' control to the cell commandbar (menu)
Set ctrl = Application.CommandBars("Cell").Controls.Add _
(Type:=msoControlPopup, Before:=6)
ctrl.Caption = "Validation Check..."
'add the submenus
Set btn = ctrl.Controls.Add
btn.Caption = "List Correct?" 'give them a name
btn.OnAction = "ValidationCheck" 'the routine called by the control
End Sub

Sub DeleteCustomMenu()
Dim ctrl As CommandBarControl

'go thru all the cell commandbar controls and delete our menu item
For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "New Edit..." Then ctrl.Delete
If ctrl.Caption = "Validation Check..." Then ctrl.Delete
Next
End Sub

Thanks again.

EM

 

[Bob Phillips]

Okay, I will try and explain why you get the problem as well as giving you a
solution.

As an aside, the method of deleting the menu and re-adding it every
right-click is a bit inefficient, it only needs to be done on workbook open
and deleted on close.

Anyway, to the problem. Your delete code looks like this

For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "New Edit..." Then ctrl.Delete
If ctrl.Caption = "Validation Check..." Then ctrl.Delete
Next

On the second time through, ctrl is the "New Edit..." control, so it deletes
it. You then immediately check it to be "Validation Check...", but ctrl was
deleted, so there is nothing to compare against, so it fails.

You can solve it by doing an If ... ElseIf ... End If construct.

For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "New Edit..." Then
ctrl.Delete
ElseIf ctrl.Caption = "Validation Check..." Then
ctrl.Delete
End If
Next



--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Guest]

I think I am going to name my kid after you (due in April!). This problem
has been driving me nuts! Thanks so much. Two three questions:

1) If I call the build/delete subs in the Open/Close events as you suggest
does the open event reside in the class module as App_WorkbookOpen?
2) Does doing this mean I have to change the new IF stmt you just put in the
Delete sub?
3) As the menu items grow, I can see the IF getting quite large in the
Delete sub. If I plan on adding to these, how do I minimize the code in this
module.

Thanks again you have been very helpful.

EM

 

[Bob Phillips]

I think I am going to name my kid after you (due in April!). This problem
has been driving me nuts! Thanks so much. Two three questions:

1) If I call the build/delete subs in the Open/Close events as you suggest
does the open event reside in the class module as App_WorkbookOpen?

No. because that means the event would trigger when an y workbook is opened
after that one, when you want it to apply to when that workbook is opened.
So just add it to a normal Workbook_Open of ThisWorkbook in the workbook
that will create this functionality.

2) Does doing this mean I have to change the new IF stmt you just put in the
Delete sub?

No not at all. You currently get it when you second-time right-click,
beacuse it tries to delete the controls before re-creating them. If you
change it to a 'do once' method, you won't get the problem so quickly with
the old code, but you will still get it when you close the workbook. So the
change is still valid.

3) As the menu items grow, I can see the IF getting quite large in the
Delete sub. If I plan on adding to these, how do I minimize the code in this
module.

I would just do away with the If and wrap it in an On Error

On Error resume Next
With Application.CommandBars("Cell")
.Controls("New Edit...").Delete
.Controls("Validation Check...").Delete Then
ctrl.Delete
On Error Goto 0

That way, if it exists, it is deleted nicely, if it doesn't, the Error
Resume makes sure that it doesn't fail. Adding more items will be simpler
then, and much more readable.

BTW, if you are going to add more items, you don't need to define them all
as popups and then hang single buttons off them. You usually have popups as
a grouping menu item. So you could (better) use

Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer

'add first 'popup' control to the cell commandbar (menu)
With Application.CommandBars("Cell")
Set btn = .Controls.Add (Type:=msoControlButton, Before:=5)
btn.BeginGroup = True
btn.Caption = "Copy Cell Address" 'give them a name
btn.OnAction = "CopyRangeAddress" 'the routine called by the control

'add second 'popup' control to the cell commandbar (menu)
Set btn = .Controls.Add (Type:=msoControlButton, Before:=6)
btn.Caption = "List Correct?" 'give them a name
btn.OnAction = "ValidationCheck" 'the routine called by the control
End With

Set btn = Nothing

End Sub

or even

Sub BuildCustomMenu()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Integer

'add first 'popup' control to the cell commandbar (menu)
With Application.CommandBars("Cell")
Set ctrl = .Controls.Add (Type:=msoControlPopup, Before:=5)
ctrl.BeginGroup = True
ctrl.Caption = "Menu 1"
with ctrl
Set btn = .Controls.Add(Type:=msoControlButton)
btn.Caption = "Copy Cell Address" 'give them a name
btn.OnAction = "CopyRangeAddress" 'the routine called by the
control

Set btn = .Controls.Add (Type:=msoControlButton)
btn.Caption = "List Correct?" 'give them a name
btn.OnAction = "ValidationCheck" 'the routine called by the
control
End With
End With

Set btn = Nothing

End Sub

of course the delete code would need changing accordingly