Thema: CommandBar in Abhängigkeit vorhandener Makros erstellen

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   On Error Resume Next
   Application.CommandBars("AktuelleMakros").Delete
   On Error GoTo 0
End Sub

Private Sub Workbook_Open()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim arr() As String
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("AktuelleMakros").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      Name:="AktuelleMakros", _
      Position:=msoBarTop, _
      MenuBar:=False, _
      temporary:=True)
   arr = GetMacros
   For iCounter = 1 To UBound(arr)
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = "Makro Nr. " & iCounter
         .OnAction = "MacroNo" & iCounter
         .Style = msoButtonCaption
         .FaceId = 70 + iCounter
      End With
   Next iCounter
   oBar.Visible = True
End Sub

StandardModule: basMain

Sub MacroNo1()
   MsgBox "Ich bin Makro Nr. 1"
End Sub

Sub MacroNo2()
   MsgBox "Ich bin Makro Nr. 2"
End Sub

Sub MacroNo3()
   MsgBox "Ich bin Makro Nr. 3"
End Sub

Sub MacroNo4()
   MsgBox "Ich bin Makro Nr. 4"
End Sub

Sub MacroNo5()
   MsgBox "Ich bin Makro Nr. 5"
End Sub

StandardModule: basFunction

Function GetMacros()
   Dim arrMacros() As String
   Dim var As Variant
   Dim iRow As Integer, iCounter As Integer
   With ThisWorkbook.VBProject _
      .VBComponents("basMain").CodeModule
      For iRow = 1 To .CountOfLines
         If .ProcOfLine(iRow, 0) > "" Then
            If iCounter = 0 Then
               iCounter = iCounter + 1
               ReDim Preserve arrMacros(iCounter)
               arrMacros(iCounter) = .ProcOfLine(iRow, 0)
            Else
               var = Application.Match(.ProcOfLine(iRow, 0), arrMacros, 0)
               If IsError(var) Then
                  iCounter = iCounter + 1
                  ReDim Preserve arrMacros(iCounter)
                  arrMacros(iCounter) = .ProcOfLine(iRow, 0)
               End If
            End If
         End If
      Next iRow
   End With
   GetMacros = arrMacros
End Function

Beiträge aus dem Excel-Forum zu den Themen VBE und Prozedur