Gruppe
Menue
Problem
Wie kann ich einem Menü ein weiteres Submenü hinzufügen? Die Aufschriften sollen aus einem Tabellenblatt übernommen werden. Die Makros zu den Menüpunkten haben die gleichen Namen wie die Aufschriften.
StandardModule: basMain
Sub MenuAdd()
Dim oPopUpA As CommandBarPopup
Dim oPopUpB As CommandBarPopup
Dim oBtn As CommandBarButton
Dim rng As Range
Dim iCounter As Integer
Set oPopUpA = Application.CommandBars( _
"Worksheet Menu Bar").FindControl(Id:=30007)
On Error Resume Next
oPopUpA.Controls("Projekt-Liste").Delete
On Error GoTo 0
On Error GoTo ERRORHANDLER
If ActiveSheet.Buttons(1).Caption = "Menü anlegen" Then
Set oPopUpB = oPopUpA.Controls.Add(msoControlPopup)
oPopUpB.Caption = "Projekt-Liste"
For iCounter = 1 To 10
Set oBtn = oPopUpB.Controls.Add
With oBtn
.Caption = Cells(iCounter, 1).Value
.OnAction = Cells(iCounter, 1).Value
.Style = msoButtonCaption
End With
Next iCounter
ActiveSheet.Buttons(1).Caption = "Menü löschen"
Else
ActiveSheet.Buttons(1).Caption = "Menü anlegen"
On Error Resume Next
oPopUpA.Controls("Projekt-Liste").Delete
On Error GoTo 0
End If
Exit Sub
ERRORHANDLER:
MsgBox prompt:="Das Menü kann nicht erstellt werden!"
End Sub