Sub ReadAndMakeCommandBar()
Dim newBar As CommandBar
Dim ArrNames As Variant, i As Long
ArrNames = ListOfSubs
For i = 1 To UBound(ArrNames)
ArrNames(i) = Replace(ArrNames(i), "()", vbNullString)
ArrNames(i) = Split(ArrNames(i), "Sub ")(1)
Next i
MsgBox RRayStr(ArrNames, vbCr)
On Error Resume Next
Application.CommandBars("MyFloatingMenu").Delete
On Error GoTo 0
Set newBar = Application.CommandBars.Add("MyFloatingMenu", Position:=msoBarFloating, temporary:=True)
With newBar
.Width = 135
For i = 1 To UBound(ArrNames)
Select Case LCase(ArrNames(i))
Case "readandmakecommandbar", "makecommandbar"
Rem do nothing
Case Else
Rem make a button
With .Controls.Add(Type:=msoControlButton, temporary:=True)
.Style = msoButtonCaption
.Caption = ArrNames(i)
.Visible = True
.OnAction = ArrNames(i)
.Width = 130
End With
End Select
Next i
.Top = 200
.Left = 900
.Visible = True
End With
End Sub
Function ListOfSubs() As Variant
Dim oneVBComp As VBComponent
Dim oneModule As CodeModule
Dim xStr As String, i As Long
Dim arrSubNames() As String, SubCount As Long
ReDim arrSubNames(1 To 1)
With ThisWorkbook.VBProject
For Each oneVBComp In .VBComponents
With oneVBComp
If .Type = vbext_ct_StdModule Then
With .CodeModule
For i = 1 To .CountOfLines
If .Lines(i, 1) Like "*Sub *()" Then
SubCount = SubCount + 1
If UBound(arrSubNames) < SubCount Then ReDim Preserve arrSubNames(1 To 2 * SubCount)
arrSubNames(SubCount) = .Lines(i, 1)
End If
Next i
End With
End If
End With
Next oneVBComp
End With
If SubCount > 0 Then
ReDim Preserve arrSubNames(1 To SubCount)
Else
ReDim arrSubNames(0 To 0)
End If
ListOfSubs = arrSubNames
End Function