Return to Snippet

Revision: 70832
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
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
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