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.
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