This is a follow up to VBEMenuButton Class.
After much trial and error I abandoned the previous approach. I decided that it would be better to create a class to instantiate the menus. When the class is terminated the menus are deleted. This only works when the class is properly terminated. When the VBA Crashes the menus remain but the handlers are destroyed.
For this reason I created two factory methods (InitCommandBarControl and InitCommandBar). These methods will return the existing control is it exists. If the control doesn't exists a new control is added and returned.
Overall I'm pretty happy with how it turned out but I'm open to criticism. After all I wouldn't have gotten this far if Greedo didn't politely point out how bad my last attempt at it was.
AutoOpenHandler: Module
Attribute VB_Name = "AutoOpenHandler"
Option Explicit
Private MyPersonalMenus As PersonalMenus
Sub InitPersonalMenus()
Set MyPersonalMenus = New PersonalMenus
End Sub
Sub DeletePersonalMenus()
Rem If the MyPersonalMenus is nothing I relinked so the Menus can be cleaned up
If MyPersonalMenus Is Nothing Then _
Set MyPersonalMenus = New PersonalMenus
Set MyPersonalMenus = Nothing
End Sub
Public Sub Auto_Open()
InitPersonalMenus
End Sub
CommandHandlerRelay: Class
The Create method of the CommandHandlerRelay class
- Returns a new instance of the class
- Set a Reference to the a Callback object
- Stores the Procedure Name of the Callback object
- Creates a listener for the CommandBarControl
When the listener is triggered an Array containing the CommandHandlerRelay and CommandBarControl are passed to the Callback object's Procedure.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1
END
Attribute VB_Name = "CommandHandlerRelay"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Rem Original Code From Pearson Software Consulting
Rem Creating Menu Items In The VBA Editor: http://www.cpearson.com/excel/vbemenus.aspx
Public CallBackObject As Object
Public ProcName As String
Public Data As Variant
Public WithEvents EvtHandler As VBIDE.CommandBarEvents
Attribute EvtHandler.VB_VarHelpID = -1
Public Property Get Create(Ctrl As CommandBarControl, pCallBackObject As Object, pProcName As String) As CommandHandlerRelay
With New CommandHandlerRelay
Set .EvtHandler = Application.VBE.Events.CommandBarEvents(Ctrl)
Set .CallBackObject = pCallBackObject
.ProcName = pProcName
Set Create = .Self
End With
End Property
Public Property Get Self() As CommandHandlerRelay
Set Self = Me
End Property
Private Sub EvtHandler_Click(ByVal CommandBarControl As Object, _
handled As Boolean, CancelDefault As Boolean)
'On Error Resume Next
CallByName CallBackObject, ProcName, VbMethod, Array(Self, CommandBarControl)
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Tell VBIDE that we've handled the event.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
handled = True
CancelDefault = True
End Sub
CommandBarFactory: Module
Attribute VB_Name = "CommandBarFactory"
Option Explicit
Public Function InitCommandBarControl(Controls As CommandBarControls, ControlType As MsoControlType, TagId As String) As CommandBarControl
Dim Ctrl As CommandBarControl
Set Ctrl = Controls.Parent.FindControl(Tag:=TagId)
If Ctrl Is Nothing Then
Set Ctrl = Controls.Add(Type:=ControlType, Temporary:=True)
Ctrl.Tag = TagId
End If
Set InitCommandBarControl = Ctrl
End Function
Public Function InitCommandBar(CBars As CommandBars, Ctrl As CommandBar, Name As String, Optional Position As Long, Optional MenuBar As String) As CommandBar
On Error Resume Next
Set Ctrl = CBars(Name)
If Err.Number <> 0 Then
Set Ctrl = CBars.Add(Name:=Name, Position:=Position, MenuBar:=MenuBar, Temporary:=True)
End If
On Error GoTo 0
Set InitCommandBar = Ctrl
End Function
PersonalMenus: Class
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "PersonalMenus"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private PersonalMenu As CommandBarPopup
Private ShowUserformsMenu As CommandBarPopup
Private WithEvents ShowUserformsListener As VBIDE.CommandBarEvents
Private ShowTablesMenu As CommandBarPopup
Private WithEvents ShowTablesListener As VBIDE.CommandBarEvents
Private WithEvents ClearImmediateWindowButton As CommandBarButton
Private WithEvents ShowVBEditor As CommandBarButton
Option Explicit
Private PersonalMenu As CommandBarPopup
Private ShowUserformsMenu As CommandBarPopup
Private WithEvents ShowUserformsListener As VBIDE.CommandBarEvents
Private ShowTablesMenu As CommandBarPopup
Private WithEvents ShowTablesListener As VBIDE.CommandBarEvents
Private WithEvents ClearImmediateWindowButton As CommandBarButton
Private WithEvents ShowVBEditor As CommandBarButton
Private Sub Class_Initialize()
Rem Add "Personal" Menu to VBE Menu Bar
Set PersonalMenu = InitCommandBarControl(MenuBar.Controls, msoControlPopup, "PersonalMenu")
PersonalMenu.Caption = "Personal"
Rem Add "Show Userforms" Menu Personal Menu
Set ShowUserformsMenu = InitCommandBarControl(PersonalMenu.Controls, msoControlPopup, "ShowUserformsMenu")
ShowUserformsMenu.Caption = "Show Userforms"
Rem Add "Show Userforms" Menu Listener
Rem When Clicked the Menu Adds a Submenu for each Workbook that has a Userform
Rem A Menu Button is added for each Userform
Set ShowUserformsListener = Application.VBE.Events.CommandBarEvents(ShowUserformsMenu)
Rem Add "Show Tables" Menu Personal Menu
Set ShowTablesMenu = InitCommandBarControl(PersonalMenu.Controls, msoControlPopup, "ShowTablesMenu")
Rem Add "Show Tables" Menu Listener
Rem When Clicked the Menu Adds a Submenu for each Workbook that has a ListObject
Rem A Menu Button is added for each ListObject
ShowTablesMenu.Caption = "Show Tables"
Set ShowTablesListener = Application.VBE.Events.CommandBarEvents(ShowTablesMenu)
Rem Init the ClearImmediateWindowButton
Rem There is no need use a VBIDE.CommandBarEvents listener
Rem Use WithEvents for non-dynamic ControlButton and ControlComboBox controls
Set ClearImmediateWindowButton = InitCommandBarControl(PersonalMenu.Controls, msoControlButton, "ClearImmediateWindowButton")
ClearImmediateWindowButton.Caption = "Clear Immediate Window"
Rem Add a ShowVBEditor button to the Cell's context menu
Set ShowVBEditor = InitCommandBarControl(CellMenu.Controls, msoControlButton, "ShowVBEditor")
ShowVBEditor.Caption = "Show VBEditor"
End Sub
Private Function MenuBar() As CommandBar
Set MenuBar = Application.VBE.CommandBars("Menu Bar")
End Function
Private Function CellMenu() As CommandBar
Set CellMenu = Application.CommandBars("Cell")
End Function
Private Sub Class_Terminate()
Rem Find our CommandBarControls and delte them if they exists
On Error Resume Next
InitCommandBarControl(MenuBar.Controls, msoControlPopup, "PersonalMenu").Delete
InitCommandBarControl(CellMenu.Controls, msoControlPopup, "ShowVBEditor").Delete
On Error GoTo 0
End Sub
Private Sub ClearImmediateWindowButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Application.SendKeys "^g ^a {DEL}"
End Sub
Rem This button is added to the Cell context menu
Private Sub ShowVBEditor_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
With Application.VBE.MainWindow
.Visible = True
.WindowState = vbext_ws_Maximize
End With
Rem CancelDefault needs to be set to true to prevent the control's OnAction method event from triggering
Rem I do this so that I do not need to create a methos in a standard maodule to handle the button clock
CancelDefault = True
End Sub
Private Sub ShowUserformsListener_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
Rem Delete All Existing Menu Items
While ShowUserformsMenu.Controls.Count > 0
ShowUserformsMenu.Controls(1).Delete
Wend
Static Listerners As Collection
Set Listerners = New Collection
AddShowUserFormMenus Listerners
handled = True
CancelDefault = True
End Sub
Private Sub AddShowUserFormMenus(Listerners As Collection)
Dim wb As Workbook
Dim Component As VBComponent
Dim Handler As CommandHandlerRelay
Dim Button As CommandBarButton
Dim Menu As CommandBarPopup
For Each wb In Workbooks
Set Menu = Nothing
For Each Component In wb.VBProject.VBComponents
Rem Check if the VBComponent is an Userform
If Component.Type = vbext_ct_MSForm Then
Rem Create a Menu for the current workbook's Userforms Menu Items
If Menu Is Nothing Then
Set Menu = InitCommandBarControl(ShowUserformsMenu.Controls, msoControlPopup, wb.Name)
Menu.Caption = wb.Name
End If
Rem Add a Menu Button with the Userform Name as the Caption
Set Button = InitCommandBarControl(Menu.Controls, msoControlButton, wb.Name & ":" & Component.Name)
Button.Caption = Component.Name
Rem Create a CommandHandlerRelay to listen for the Userform's Menu Item click event
Rem Assign an array of relavent data to the CommandHandlerRelay Data Field
Set Handler = CommandHandlerRelay.Create(Button, Me, "ShowUserFormHandler")
Handler.Data = Array(wb, Component)
Listerners.Add Handler
End If
Next
Next
End Sub
Rem Handles the USerform Menu Item click event
Rem CommandHandlerRelay passes is an array of data when this macro is called
Public Sub ShowUserFormHandler(Args() As Variant)
Dim Handler As CommandHandlerRelay
Dim Ctrl As CommandBarControl
Dim Data() As Variant
Set Handler = Args(0)
Set Ctrl = Args(1)
Data = Handler.Data
Dim Component As VBComponent
Set Component = Data(1)
With Component.DesignerWindow
.Visible = True
.SetFocus
SendKeys "{F5}"
End With
End Sub
Private Sub ShowTablesListener_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
Rem Delete All Existing Menu Items
While ShowTablesMenu.Controls.Count > 0
ShowTablesMenu.Controls(1).Delete
Wend
Static Listerners As Collection
Set Listerners = New Collection
AddShowTablesMenus Listerners
handled = True
CancelDefault = True
End Sub
Private Sub AddShowTablesMenus(Listerners As Collection)
Dim wb As Workbook
Dim ws As Worksheet
Dim Handler As CommandHandlerRelay
Dim Button As CommandBarButton
Dim Menu As CommandBarPopup
Dim ListObject As ListObject
For Each wb In Workbooks
Set Menu = Nothing
For Each ws In wb.Worksheets
For Each ListObject In ws.ListObjects
Rem Create a Menu for the current ListObject Menu Items
If Menu Is Nothing Then
Set Menu = InitCommandBarControl(ShowTablesMenu.Controls, msoControlPopup, wb.Name)
Menu.Caption = wb.Name
End If
Rem Add a Menu Button with the ListObject Name as the Caption
Set Button = InitCommandBarControl(Menu.Controls, msoControlButton, wb.Name & ":" & ListObject.Name)
Button.Caption = ListObject.Name
Rem Create a CommandHandlerRelay to listen for the Userform's Menu Item click event
Rem Assign an array of relavent data to the CommandHandlerRelay Data Field
Set Handler = CommandHandlerRelay.Create(Button, Me, "ShowUserTablesHandler")
Handler.Data = Array(wb, ws, ListObject)
Listerners.Add Handler
Next
Next
Next
End Sub
Rem Handles the ListObject Menu Item click event
Rem CommandHandlerRelay passes is an array of data when this macro is called
Public Sub ShowUserTablesHandler(Args() As Variant)
Dim Handler As CommandHandlerRelay
Dim Ctrl As CommandBarControl
Dim Data() As Variant
Set Handler = Args(0)
Set Ctrl = Args(1)
Data = Handler.Data
Dim ListObject As ListObject
Set ListObject = Data(2)
Application.Goto ListObject.HeaderRowRange, True
End Sub
