To have an easy access to any and all macros that are anywhere present in the open documnets or loaded addins a little addin has been created that makes all macros accessible via a popup menu structure. The commandbar has two objects. A: the Macro popup menu structure itself, and B: a button to renew the menu when required. When the application is started only a “Starter” button is there to avoid any delay in application start-up times for building the popup menu tree when very many Addins with lots of macros are installed.
![Macrolister](https://exceltune.wordpress.com/wp-content/uploads/2014/02/macrolister.jpg?w=800&h=520)
Microsoft Excel Object ThisWorkbook
'---------------------------------------------------------------------------
' Module : ThisWorkbook
' Author : Hartmut Gruenhagen
' Date : 06-Feb-14
' Purpose : Adds commandbar for the Macrolister to the Addins-menu
'---------------------------------------------------------------------------
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars(myCmdbarLoader).Delete
Application.CommandBars(myCmdbarTitle).Delete
On Error GoTo 0
End Sub
Private Sub Workbook_Open()
Call BuildMenu
End Sub
Module VBA_MacroLister
'--------------------------------------------------------------------------
' Module : VBA_MacroLister
' Author : Hartmut Gruenhagen
' Date : 06-Feb-14
' Purpose : Macrolister Code module that builds the popup menu structure
'--------------------------------------------------------------------------
Option Explicit
Global TheMacroFile As String
#If VBA7 Then
Public Declare PtrSafe Function GetAsyncKeyState Lib _
"user32.dll" (ByVal vKey As Long) As Integer
#Else
Public Declare Function GetAsyncKeyState Lib "user32.dll" _
(ByVal vKey As Long) As Integer
#End If
Const myPopup = "MacroLister"
Public Const myCmdbarTitle = "MacroMenuTree"
Public Const myCmdbarLoader = "MacroTreeLoader"
Private myCmdbar As CommandBar
Sub BuildMenu()
Dim j As Long
Dim PopupA As CommandBarControl
With Application.CommandBars(1)
On Error Resume Next
.Controls(myPopup).Delete
On Error GoTo 0
Set PopupA = .Controls.Add(Type:=msoControlPopup, _
Before:=.FindControl(ID:=30010).Index, _
Temporary:=True)
End With
'
With PopupA
.Caption = myPopup
'
' Build and show Macro Popup menu
'
With .Controls.Add(Type:=msoControlButton)
.Caption = "Load Macro Menu"
.OnAction = "BuildAndShowCmdbar"
.TooltipText = "Build VBA Macro List Menu Tree"
.Style = MsoButtonStyle.msoButtonIconAndCaption
.FaceId = 420
.Enabled = True
End With
End With
End Sub
Sub BuildAndShowCmdbar()
On Error Resume Next
' destroy old custom menu and rebuild from scratch
Application.CommandBars(myCmdbarTitle).Delete
On Error GoTo 0
Set myCmdbar = Application.CommandBars.Add(myCmdbarTitle, _
MsoBarPosition.msoBarTop, _
MsoBarType.msoBarTypeNormal, True)
With myCmdbar.Controls
Do While .Count > 0
.Item(.Count).Delete ' deleting the old entries
Loop
End With
Dim myVBP As VBProject
Dim aProjPopUp As CommandBarPopup
Dim aButton As CommandBarButton
Dim VBComp As VBIDE.VBComponent
Dim VBlines As Long
Dim MasterPopUp As CommandBarPopup
Dim sWbName As String
Dim i As Long
Dim wasProtected As Boolean
wasProtected = False
Set MasterPopUp = myCmdbar.Controls.Add(msoControlPopup)
MasterPopUp.Caption = "Macros"
For Each myVBP In Application.VBE.VBProjects
On Error GoTo protectedXLA
For Each VBComp In myVBP.VBComponents
If wasProtected Then
wasProtected = False
GoTo jumptonext
End If
On Error GoTo 0
VBlines = TotalCodeLinesInVBComponent(VBComp)
If VBlines > 2 Then
' usually 3 lines is the minimum for functional code
Set aProjPopUp = MasterPopUp.Controls.Add(msoControlPopup)
' TheMacroFile is a global variable that is required in
' "addRoutinesToPopup(..."
' new unsaved files will create an error for "myVBP.Filename"
On Error Resume Next
sWbName = ""
sWbName = Dir(myVBP.Filename)
On Error GoTo 0
If Len(sWbName) = 0 Then
Debug.Print "(Unsaved Workbook)"
TheMacroFile = "unsaved " & myVBP.Name
Else
TheMacroFile = Right(myVBP.Filename, Len(myVBP.Filename) - _
InStrRev(myVBP.Filename, _
"\", , vbTextCompare))
End If
aProjPopUp.Caption = TheMacroFile
addCodemodulesToPopup aProjPopUp.CommandBar, myVBP
Exit For
End If
On Error GoTo protectedXLA
Next VBComp
jumptonext:
Next myVBP
On Error GoTo 0
Set aButton = myCmdbar.Controls.Add
'Add values to the created new button.
With aButton
'.BeginGroup = True
.Caption = "Rebuild macro list"
.FaceId = 346
.OnAction = "BuildAndShowCmdbar"
.Style = MsoButtonStyle.msoButtonIcon
.TooltipText = "Rebuild macro list"
.Enabled = True
End With
myCmdbar.Visible = True
On Error Resume Next
Application.CommandBars(myCmdbarLoader).Delete
On Error GoTo 0
Exit Sub
protectedXLA:
wasProtected = True
i = i + 1
Debug.Print "protected project number : " & i
Set aProjPopUp = MasterPopUp.Controls.Add(msoControlPopup)
' TheMacroFile is a global variable that is required in
' "addRoutinesToPopup(..."
' new unsaved files will create an error for "myVBP.Filename"
On Error Resume Next
sWbName = ""
sWbName = Dir(myVBP.Filename)
On Error GoTo 0
If Len(sWbName) = 0 Then
Debug.Print "(Unsaved Workbook)"
TheMacroFile = "unsaved " & myVBP.Name
Else
TheMacroFile = Right(myVBP.Filename, Len(myVBP.Filename) - _
InStrRev(myVBP.Filename, _
"\", , vbTextCompare))
End If
aProjPopUp.Caption = TheMacroFile & " has VBA protection!"
' aProjPopUp.FaceId = 330
Resume Next
End Sub
Function WorkbookOfVBProject(WhichVBP As Variant) As Workbook
' by Chip Pearson
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' WorkbookOfVBProject
' This returns the Workbook object for a specified VBIDE.VBProject.
' The parameter WhichVBP can be any of the following:
' A VBIDE.VBProject object
' A string containing the name of the VBProject.
' The index number (ordinal position in Project window) of the VBProject.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim WB As Workbook
Dim AI As AddIn
Dim VBP As VBIDE.VBProject
If IsObject(WhichVBP) = True Then
' If WhichVBP is an object, it must be of the
' type VBIDE.VBProject. Any other object type
' throws an error 13 (type mismatch).
On Error GoTo 0
If TypeOf WhichVBP Is VBIDE.VBProject Then
Set VBP = WhichVBP
Else
Err.Raise 13
End If
Else
On Error Resume Next
Err.Clear
' Here, WhichVBP is either the string name of
' the VBP or its ordinal index number.
Set VBP = Application.VBE.VBProjects(WhichVBP)
On Error GoTo 0
If VBP Is Nothing Then
Err.Raise 9
End If
End If
For Each WB In Workbooks
If WB.VBProject Is VBP Then
Set WorkbookOfVBProject = WB
Exit Function
End If
Next WB
' not found in workbooks, search installed add-ins.
For Each AI In Application.AddIns
If AI.Installed = True Then
If Workbooks(AI.Name).VBProject Is VBP Then
Set WorkbookOfVBProject = Workbooks(AI.Name)
Exit Function
End If
End If
Next AI
End Function
Public Sub MacroListPopup(Optional VBprojectName As String)
' the main procedure to build the popup menu at run time and
' to show it then to the user for normal use it should be
' started via a menu and commandbar button.
Dim myaddin As AddIn
Dim myVBP As VBProject
Dim myBar As CommandBar
Dim ctrl As CommandBarButton
Dim a As AddIn
Dim s As String
If VBprojectName <> "" Then
Debug.Print "MacroListPopup called w/ argument - VBprojectName: " _
& VBprojectName
Set myVBP = Application.VBE.VBProjects(VBprojectName)
Else
' Debug.Print "no VBprojectName"
Set ctrl = Application.CommandBars.ActionControl
If Not ctrl Is Nothing Then
s = ctrl.Parameter
Debug.Print "VBproject name from Ctrl.Parameter: " & s
Else
s = ThisWorkbook.Name
Debug.Print "VBproject name from ThisWorkbook.Name: " & s
End If
s = Right(s, Len(s) - InStrRev(s, "\", , vbTextCompare))
If InStr(1, s, ".XLSB", vbTextCompare) > 0 Then
Set myVBP = Application.Workbooks(s & "b").VBProject
ElseIf InStr(1, s, ".XLS", vbTextCompare) > 0 Then
Set myVBP = Application.Workbooks(s).VBProject
Else
If Application.Name = "Microsoft Excel" Then
If Not ActiveWorkbook Is Nothing Then
If Not ctrl Is Nothing Then
Set myaddin = AddIns.Add(ctrl.Parameter)
Set myVBP = Application.Workbooks(myaddin.Name).VBProject
Else
Set myVBP = Application.Workbooks(s).VBProject
End If
Else
s = Right(s, Len(s) - InStrRev(s, "\", , vbTextCompare))
Set myVBP = Application.Workbooks(s).VBProject
End If
ElseIf Application.Name = "Microsoft PowerPoint" Then
Set myaddin = AddIns.Add(ctrl.Parameter)
Set myVBP = Application.Presentations(myaddin.Name).VBProject
End If
End If
End If
On Error Resume Next
' destroy old custom menu and rebuild from scratch
Application.CommandBars("MacroList").Delete
On Error GoTo 0
Set myBar = Application.CommandBars.Add(Name:="MacroList", _
Position:=msoBarPopup)
If Not myBar Is Nothing Then
TheMacroFile = Right(myVBP.Filename, Len(myVBP.Filename) - _
InStrRev(myVBP.Filename, _
"\", , vbTextCompare))
If myVBP Is Nothing Then 'Not open
MsgBox "No " & TheMacroFile & " macro file open!" & _
Chr(10) & Chr(10) & "Cannot list macros.", _
vbCritical, "myTools"
On Error GoTo 0
Else 'macro file is open
addCodemodulesToPopup myBar, myVBP
' we better sort the popup entries
On Error GoTo 0
SortCmdBar myBar 'aCmdbar
If Not ctrl Is Nothing Then
' let the popup menu appear underneath the main
' comandbar control that started this
myBar.ShowPopup x:=ctrl.Left, _
y:=ctrl.Top + myBar.Controls(1).Height
Else
myBar.ShowPopup x:=200, _
y:=200 + myBar.Controls(1).Height
End If
Set myVBP = Nothing
End If
End If
End Sub
Private Sub addCodemodulesToPopup(WindowCmdBar As CommandBar, _
aVBProject As VBProject)
Dim aModulePopUp As CommandBarPopup
Dim VBComp As VBIDE.VBComponent
Dim VBlines As Long
Dim newForm As Boolean
Dim newModule As Boolean
Dim newClass As Boolean
On Error Resume Next
For Each VBComp In aVBProject.VBComponents
VBlines = TotalCodeLinesInVBComponent(VBComp)
If VBlines > 2 Then
' usually 3 lines is the minimum for functional code
Set aModulePopUp = WindowCmdBar.Controls.Add(msoControlPopup)
Select Case VBComp.Type
Case vbext_ct_StdModule
aModulePopUp.Caption = "mod " & VBComp.Name
Case vbext_ct_Document
If VBComp.Name = "ThisWorkbook" Then
aModulePopUp.Caption = VBComp.Name
Else
aModulePopUp.Caption = "Sheet " & _
VBComp.Properties("Name").Value
End If
Case vbext_ct_MSForm
aModulePopUp.Caption = "frm " & VBComp.Name
Case vbext_ct_ClassModule
aModulePopUp.Caption = "cls " & VBComp.Name
End Select
addRoutinesToPopup aModulePopUp.CommandBar, VBComp
End If
Next VBComp
End Sub
Private Sub addRoutinesToPopup(moduleCmdBar As CommandBar, _
VBComp As VBIDE.VBComponent)
Dim ProcKind As VBIDE.vbext_ProcKind
Dim LineNum As Long
Dim ProcName As String
Dim aButton As CommandBarButton
With VBComp.CodeModule
LineNum = .CountOfDeclarationLines + 1
Do Until LineNum >= .CountOfLines
ProcName = .ProcOfLine(LineNum, ProcKind)
Set aButton = moduleCmdBar.Controls.Add(msoControlButton)
aButton.Caption = ProcName ' the sub or Function name
Select Case TypeOfProc(.Lines(.ProcBodyLine(ProcName, ProcKind), 1))
Case "Sub"
aButton.FaceId = 186
Case "Sub with optional Param."
aButton.FaceId = 156
Case "Sub with Param."
aButton.FaceId = 187
Case "Function"
aButton.FaceId = 385
Case Else
aButton.FaceId = 190
End Select
aButton.Parameter = TheMacroFile 'the file name containing the macros
aButton.Tag = VBComp.Name ' the code module name
aButton.OnAction = "StartOrGotoSpecificMacro" '"GotoProcedure"
LineNum = LineNum + .ProcCountLines(ProcName, ProcKind) + 1
Loop
End With
End Sub
Function TypeOfProc(procTitleLine As String) As String
If InStr(1, procTitleLine, "Sub", vbTextCompare) Then
If InStr(1, procTitleLine, "()", vbTextCompare) Then
TypeOfProc = "Sub"
ElseIf InStr(1, procTitleLine, "(Optional", vbTextCompare) Then
TypeOfProc = "Sub with optional Param."
Else
TypeOfProc = "Sub with Param."
End If
Exit Function
ElseIf InStr(1, procTitleLine, "Function", vbTextCompare) Then
TypeOfProc = "Function"
Exit Function
Else
TypeOfProc = "unknown"
End If
End Function
'------------------------------------------------------------------------------
' Total Code Lines In A Component
'
Public Function TotalCodeLinesInVBComponent(VBComp As VBIDE.VBComponent) As Long
' original from Chip Pearson
' modified
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This returns the total number of code lines (excluding blank lines and
' comment lines) in the VBComponent referenced by VBComp. Returns -1
' if the VBProject is locked.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim s As String
Dim LineCount As Long
If VBComp.Collection.Parent.Protection = vbext_pp_locked Then
TotalCodeLinesInVBComponent = -1
MsgBox "VBA protection discovered"
Exit Function
End If
On Error Resume Next
With VBComp.CodeModule
For N = 1 To .CountOfLines
s = .Lines(N, 1)
If Trim(s) = vbNullString Then
' blank line, skip it
ElseIf Left(Trim(s), 1) = "'" Then
' comment line, skip it
Else
LineCount = LineCount + 1
End If
Next N
End With
TotalCodeLinesInVBComponent = LineCount
End Function
Private Sub SortCmdBar(WindowCmdBar As CommandBar)
Dim CmdCaptions() As Variant
Dim i As Integer
Dim j As Variant
Dim s As String
i = WindowCmdBar.Controls.Count
Redim CmdCaptions(i)
For i = 1 To WindowCmdBar.Controls.Count
CmdCaptions(i) = WindowCmdBar.Controls(i).Caption
Next i
BubbleSort CmdCaptions
For i = WindowCmdBar.Controls.Count To 1 Step -1
'1 To WindowCmdBar.Controls.Count
j = WindowCmdBar.Controls(CmdCaptions(i)).Index
WindowCmdBar.Controls(j).Move Before:=1
Next i
s = Left(WindowCmdBar.Controls(1).Caption, 4)
For i = 2 To WindowCmdBar.Controls.Count
If Left(WindowCmdBar.Controls(i).Caption, 4) <> s Then
WindowCmdBar.Controls(i).BeginGroup = True
s = Left(WindowCmdBar.Controls(i).Caption, 4)
End If
Next i
End Sub
Sub BubbleSort(MyArray() As Variant)
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
First = Lbound(MyArray)
Last = Ubound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
Temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = Temp
End If
Next j
Next i
End Sub
'--------------------------------------------------------------------------
' Procedure : StartOrGotoSpecificMacro
' Author : Hartmut Gruenhagen
' Date : 06-Feb-14
' Purpose : Starts a Macro when the menu is clicked.
' or opens the VBA editor when the "Ctrl" is pressed while
' clicking the menu. Subs with parameters, Functions, etc.
' will always be opened in the VBA editor.
'--------------------------------------------------------------------------
'
Sub StartOrGotoSpecificMacro()
Dim lStartLine As Long
Dim cmdBtn As CommandBarButton
Dim myAppl As Object
On Error Resume Next
Set cmdBtn = Application.CommandBars.ActionControl
If cmdBtn Is Nothing Then Exit Sub
If Application.Name = "Microsoft Excel" Then
Set myAppl = Application.Workbooks(cmdBtn.Parameter)
ElseIf Application.Name = "Microsoft PowerPoint" Then
Set myAppl = Application.Presentations(cmdBtn.Parameter)
ElseIf Application.Name = "Microsoft Word" Then
Set myAppl = Application.Documents(cmdBtn.Parameter)
ElseIf Application.Name = "Microsoft Access" Then
Set myAppl = Application.VBE.ActiveVBProject
End If
If Application.Name <> "Microsoft Access" Then
With myAppl.VBProject.VBComponents(cmdBtn.Tag).CodeModule
If Key_pressed(vbKeyControl) Then
lStartLine = .ProcBodyLine(cmdBtn.Caption, 0)
.CodePane.SetSelection lStartLine, 1, lStartLine, 1
.CodePane.Show
Else
Select Case TypeOfProc(.Lines(.ProcBodyLine(cmdBtn.Caption, _
0), 1))
Case "Sub", "Sub with optional Param."
Debug.Print "starting: " & "'" & cmdBtn.Parameter & "'!" & cmdBtn.Tag & _
"." & cmdBtn.Caption
Application.Run "'" & cmdBtn.Parameter & "'!" & _
cmdBtn.Tag & "." & cmdBtn.Caption
Case Else
lStartLine = .ProcBodyLine(cmdBtn.Caption, 0)
.CodePane.SetSelection lStartLine, 1, lStartLine, 1
.CodePane.Show
End Select
End If
End With
Else
With myAppl.VBComponents(cmdBtn.Tag).CodeModule
If Key_pressed(vbKeyControl) Then
lStartLine = .ProcBodyLine(cmdBtn.Caption, 0)
.CodePane.SetSelection lStartLine, 1, lStartLine, 1
.CodePane.Show
Else
Select Case TypeOfProc(.Lines(.ProcBodyLine(cmdBtn.Caption, 0), 1))
Case "Sub", "Sub with optional Param."
Debug.Print "starting: " & "'" & cmdBtn.Parameter & "'!" & cmdBtn.Tag & _
"." & cmdBtn.Caption
Application.Run "'" & cmdBtn.Parameter & "'!" & cmdBtn.Tag & _
"." & cmdBtn.Caption
Case Else
lStartLine = .ProcBodyLine(cmdBtn.Caption, 0)
.CodePane.SetSelection lStartLine, 1, lStartLine, 1
.CodePane.Show
End Select
End If
End With
End If
End Sub
Function Key_pressed(key_to_check As Long) As Boolean
If GetAsyncKeyState(key_to_check) And &H8000 Then
Key_pressed = True
Else
Key_pressed = False
End If
End Function