Revision: 70832
Updated Code
at July 28, 2016 00:02 by cueballrawn
Updated Code
'THISWORKBOOK (paste into ThisWorkbook, macros that open and closed menus when launching and closing spreadsheet) Private Sub Workbook_Open() MsgBox "You can right-click any worksheet cell" & vbCrLf & _ "to see and / or run your workbook's macros.", 64, "A tip:" Run "RightClickReset" Run "MakeMenu" End Sub Private Sub Workbook_Activate() Run "RightClickReset" Run "MakeMenu" End Sub Private Sub Workbook_Deactivate() Run "RightClickReset" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Run "RightClickReset" ThisWorkbook.Save End Sub 'DEMONSTRATIONMACROS (paste into module DemonstrationMacros, macros you want to launch from the custom menu, these are examples) Sub Macro1() MsgBox "This is Macro1.", 64, "Test 1" End Sub Private Sub Macro2() MsgBox "This is Macro2.", 64, "Test 2" End Sub Sub Macro3() MsgBox "This is Macro3.", 64, "Test 3" End Sub 'MAINTENANCEMACROS (paste into module MaintenanceMacros, macros for creation and running of custom menu) Private Sub RightClickReset() On Error Resume Next CommandBars("Cell").Controls("Macro List").Delete Err.Clear CommandBars("Cell").Reset End Sub Private Sub MakeMenu() Run "RightClickReset" Dim objCntr As CommandBarControl, objBtn As CommandBarButton Dim strMacroName$ Set objCntr = _ Application.CommandBars("Cell").Controls.Add(msoControlPopup, before:=1) objCntr.Caption = "Macro List" Application.CommandBars("Cell").Controls(2).BeginGroup = True Dim intLine%, intArgumentStart%, strLine$, objComponent As Object For Each objComponent In ActiveWorkbook.VBProject.VBComponents If objComponent.Type = 1 Then For intLine = 1 To objComponent.CodeModule.CountOfLines strLine = objComponent.CodeModule.Lines(intLine, 1) strLine = Trim$(strLine) 'Remove indented spaces If Left$(strLine, 3) = "Sub" Or Left$(strLine, 11) = "Private Sub" Then intArgumentStart = InStr(strLine, "()") If intArgumentStart > 0 Then If Left$(strLine, 3) = "Sub" Then strMacroName = Trim(Mid$(strLine, 4, intArgumentStart - 4)) Else strMacroName = Trim(Mid$(strLine, 12, intArgumentStart - 12)) End If If strMacroName <> "RightClickReset" And strMacroName <> "MakeMenu" Then If strMacroName <> "MacroChosen" Then Set objBtn = objCntr.Controls.Add With objBtn .Caption = strMacroName .Style = msoButtonIconAndCaption .OnAction = "MacroChosen" .FaceId = 643 End With End If End If End If End If Next intLine End If Next objComponent End Sub Private Sub MacroChosen() With Application Run .CommandBars("Cell").Controls(1).Controls(.Caller(1)).Caption End With End Sub
Revision: 70831
Updated Code
at July 28, 2016 00:00 by cueballrawn
Updated Code
'THISWORKBOOK (open and closed menus when launching and closing spreadsheet) Private Sub Workbook_Open() MsgBox "You can right-click any worksheet cell" & vbCrLf & _ "to see and / or run your workbook's macros.", 64, "A tip:" Run "RightClickReset" Run "MakeMenu" End Sub Private Sub Workbook_Activate() Run "RightClickReset" Run "MakeMenu" End Sub Private Sub Workbook_Deactivate() Run "RightClickReset" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Run "RightClickReset" ThisWorkbook.Save End Sub 'DEMONSTRATIONMACROS (macros you want to launch from the custom menu, these are examples) Sub Macro1() MsgBox "This is Macro1.", 64, "Test 1" End Sub Private Sub Macro2() MsgBox "This is Macro2.", 64, "Test 2" End Sub Sub Macro3() MsgBox "This is Macro3.", 64, "Test 3" End Sub 'MAINTENANCEMACROS (macros for creation and running of custom menu) Private Sub RightClickReset() On Error Resume Next CommandBars("Cell").Controls("Macro List").Delete Err.Clear CommandBars("Cell").Reset End Sub Private Sub MakeMenu() Run "RightClickReset" Dim objCntr As CommandBarControl, objBtn As CommandBarButton Dim strMacroName$ Set objCntr = _ Application.CommandBars("Cell").Controls.Add(msoControlPopup, before:=1) objCntr.Caption = "Macro List" Application.CommandBars("Cell").Controls(2).BeginGroup = True Dim intLine%, intArgumentStart%, strLine$, objComponent As Object For Each objComponent In ActiveWorkbook.VBProject.VBComponents If objComponent.Type = 1 Then For intLine = 1 To objComponent.CodeModule.CountOfLines strLine = objComponent.CodeModule.Lines(intLine, 1) strLine = Trim$(strLine) 'Remove indented spaces If Left$(strLine, 3) = "Sub" Or Left$(strLine, 11) = "Private Sub" Then intArgumentStart = InStr(strLine, "()") If intArgumentStart > 0 Then If Left$(strLine, 3) = "Sub" Then strMacroName = Trim(Mid$(strLine, 4, intArgumentStart - 4)) Else strMacroName = Trim(Mid$(strLine, 12, intArgumentStart - 12)) End If If strMacroName <> "RightClickReset" And strMacroName <> "MakeMenu" Then If strMacroName <> "MacroChosen" Then Set objBtn = objCntr.Controls.Add With objBtn .Caption = strMacroName .Style = msoButtonIconAndCaption .OnAction = "MacroChosen" .FaceId = 643 End With End If End If End If End If Next intLine End If Next objComponent End Sub Private Sub MacroChosen() With Application Run .CommandBars("Cell").Controls(1).Controls(.Caller(1)).Caption End With End Sub
Revision: 70830
Initial Code
Initial URL
Initial Description
Initial Title
Initial Tags
Initial Language
at July 27, 2016 23:54 by cueballrawn
Initial Code
>>
Initial URL
http://www.atlaspm.com/toms-tutorials-for-excel/toms-tutorials-for-excel-customizing-your-rightclick-menu-to-list-run-macros/
Initial Description
Create a custom right-click menu that will list and launch all macros in the DemonstationMacros module. Copy and past the code into the relevant object or module.
Initial Title
Excel (VBA) Custom right-click menu to launch macros
Initial Tags
excel
Initial Language
Visual Basic