Menü- und Symbolleisten sind sowohl manuell wie auch über VBA zu erstellen, zu verändern und zu löschen.
Seit der Excel-Version 8.0 (Office 97) handelt es sich bei den Menü- und Symbolleisten um das Objektmodell der Commandbars mit den zugehörigen Control-Elementen CommandBarButton, CommandBarPopUp und CommandBarComboBox unter dem Oberbegriff CommandBarControl.
Grundsätzlich empfiehlt es sich, zu einer Arbeitsmappe gehörende CommandBars oder CommandBarControls beim Öffnen der Arbeitsmappe über das Workbook_Open-Ereignis zu erstellen und über das Workbook_BeforeClose-Ereignis zu löschen. Nur so ist gewährleistet, dass der Anwender nicht durch Auswirkungen von CommandBar-Programmierungen oder -Anbindungen belästigt wird.
Der Commandbars-Auflistung fügt man mit der Add-Methode eine neue Leiste hinzu. Erfolgt die Erstellung der neuen CommandBar in einem Klassenmodul, ist die Syntax Application.CommandBars.Add... zwingend erforderlich, erfolgt die Erstellung in einem Standardmodul, reicht ein CommandBars.Add.... Um später mögliche Kollisionen mit anderen Office-Anwendungen zu vermeiden, wird allerdings auch hier die Application-Nennung empfohlen.
Die Add-Methode kann mit bis zu 4 Parameter aufgerufen werden:
Sub CmdBarEinAus()
With Application.CommandBars("Worksheet Menu Bar")
.Enabled = Not .Enabled
End With
End Sub
Sub NewMenueBar()
Dim oCmdBar As CommandBar
Dim oPopUp As CommandBarPopup
Dim oCmdBtn As CommandBarButton
Dim datDay As Date
Dim iMonths As Integer
Call DeleteNewMenueBar
Set oCmdBar = Application.CommandBars.Add( _
Name:="MyNewCommandBar", _
Position:=msoBarTop, _
MenuBar:=True, _
temporary:=True)
Set oPopUp = oCmdBar.Controls.Add(msoControlPopup)
oPopUp.Caption = "Prüfung"
For iMonths = 1 To 12
Set oCmdBtn = oPopUp.Controls.Add
With oCmdBtn
.Caption = Format(DateSerial(1, iMonths, 1), "mmmm") & " Druck"
.OnAction = ""
.Style = msoButtonCaption
End With
Next iMonths
Set oPopUp = oCmdBar.Controls.Add(msoControlPopup)
oPopUp.Caption = "Monatsbericht"
For iMonths = 1 To 12
Set oCmdBtn = oPopUp.Controls.Add
With oCmdBtn
.Caption = Format(DateSerial(1, iMonths, 1), "mmmm") & " Druck"
.OnAction = ""
.Style = msoButtonCaption
End With
Next iMonths
Application.CommandBars("Worksheet Menu Bar").Enabled = False
oCmdBar.Visible = True
End Sub
Private Sub DeleteNewMenueBar()
On Error GoTo ERRORHANDLER
Application.CommandBars("MyNewCommandBar").Delete
Application.CommandBars("Worksheet Menu Bar").Enabled = True
End
ERRORHANDLER:
End Sub
Sub AllesAusEinBlenden()
Dim oBar As CommandBar
With CommandBars("Worksheet Menu Bar")
If .Enabled Then
.Enabled = False
Application.DisplayFullScreen = True
For Each oBar In Application.CommandBars
If oBar.Name <> "Worksheet Menu Bar" Then
If oBar.Visible Then
oBar.Visible = False
End If
End If
Next oBar
ActiveWorkbook.Protect Windows:=True
Else
ActiveWorkbook.Unprotect
.Enabled = True
Application.DisplayFullScreen = False
End If
End With
End Sub
Sub NewCalendar()
Dim oCmdBar As CommandBar
Dim oPopUp As CommandBarPopup
Dim oCmdBtn As CommandBarButton
Dim datDay As Date
Dim iMonths As Integer, iDays As Integer, iCount As Integer
On Error GoTo ERRORHANDLER
Application.CommandBars(CStr(Year(Date))).Delete
Exit Sub
ERRORHANDLER:
Set oCmdBar = Application.CommandBars.Add( _
CStr(Year(Date)), msoBarTop, False, True)
For iMonths = 1 To 12
Set oPopUp = oCmdBar.Controls.Add(msoControlPopup)
With oPopUp
.Caption = Format(DateSerial(1, iMonths, 1), "mmmm")
If iMonths Mod 3 = 1 And iMonths <> 1 Then .BeginGroup = True
iCount = Day(DateSerial(Year(Date), iMonths + 1, 0))
For iDays = 1 To iCount
datDay = DateSerial(Year(Date), iMonths, iDays)
Set oCmdBtn = oPopUp.Controls.Add
With oCmdBtn
.Caption = Day(datDay) & " - " & Format(datDay, "dddd")
.Style = msoButtonCaption
.OnAction = "GetDate"
If Weekday(datDay) = 1 And iDays <> 1 Then .BeginGroup = True
End With
Next iDays
End With
Next iMonths
oCmdBar.Visible = True
End Sub
Sub GetDate()
Dim iYear As Integer, iMonth As Integer, iDay As Integer
Dim iGroupM As Integer, iGroupD As Integer
iYear = Year(Date)
iMonth = WorksheetFunction.RoundUp(Application.Caller(2) - _
(Application.Caller(2) / 4), 0)
iDay = Application.Caller(1) - GetGroups(iMonth, Application.Caller(1))
MsgBox Format(DateSerial(iYear, iMonth, iDay), "dddd - dd. mmmm yyyy")
End Sub
Private Function GetGroups(iActMonth As Integer, iActDay As Integer)
Dim iGroups As Integer, iCounter As Integer
iCounter = 1
With Application.CommandBars(CStr(Year(Date))).Controls(iActMonth)
Do While iCounter >= .Controls.Count
If .Controls(iCounter).BeginGroup = True Then
iGroups = iGroups + 1
End If
If iCounter = iActDay - iGroups Then Exit Do
iCounter = iCounter + 1
Loop
GetGroups = iGroups
End With
End Function
Sub ListAllCommandbars()
Dim oBar As CommandBar
Dim iRow As Integer
Application.ScreenUpdating = False
Workbooks.Add 1
Cells(1, 1) = "Name"
Cells(1, 2) = "Lokaler Name"
Cells(1, 3) = "Sichtbar"
With Range("A1:C1")
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
iRow = 1
For Each oBar In Application.CommandBars
iRow = iRow + 1
Cells(iRow, 1) = oBar.Name
Cells(iRow, 2) = oBar.NameLocal
Cells(iRow, 3) = oBar.Visible
Next oBar
Columns("A:C").AutoFit
Columns("D:IV").Hidden = True
Rows(iRow + 1 & ":" & Rows.Count).Hidden = True
Application.ScreenUpdating = True
ActiveWorkbook.Saved = True
End Sub
Private Sub Worksheet_Activate()
Call NewCalendar
End Sub
Private Sub Worksheet_Deactivate()
Call NewCalendar
End Sub
Die Informationen über die CommandBars werden in einer .xlb-Datei mit je nach Excel-Version wechselndem Namen im Pfad der Anwenderbibliotheken im Excel-Verzeichnis abgelegt. Die nachfolgenden Routinen ermitteln den Namen und das Änderungs-Datum dieser Datei. Der Code ist nur ab XL9 (Office 2000) lauffähig, da die Application.UserLibraryPath- Eigenschaft bei der Vorgängerversion noch nicht implementiert war.
Sub GetXLBName()
Dim sFile As String
sFile = FindFile(0)
If sFile = "" Then
MsgBox "Die *.xlb-Datei wurde nicht gefunden!"
Else
MsgBox "Name der *.xlb-Datei: " & vbLf & sFile
End If
End Sub
Private Function FindFile() As Variant
Dim FSO As Scripting.FileSystemObject
Dim oFile As Scripting.File
Dim oFolder As Scripting.Folder
Dim arrFile As Variant
Dim datFile As Date
Dim sFile As String, sVersion As String
sVersion = Left(Application.Version, 1)
If sVersion = "8" Then
Beep
MsgBox "Nur ab Version 9.0 möglich!"
End
End If
Set FSO = New Scripting.FileSystemObject
With FSO
Set oFolder = .GetFolder(.GetFolder(.GetParentFolderName( _
Application.UserLibraryPath)).Path & "\Excel")
End With
For Each oFile In oFolder.Files
If Right(oFile.Name, 4) = ".xlb" Then
If datFile < oFile.DateLastAccessed Then
datFile = oFile.DateLastAccessed
sFile = oFile.Path
End If
End If
Next oFile
arrFile = Array(sFile, datFile)
FindFile = arrFile
End Function
Sub GetXLBDate()
Dim datFile As Date
datFile = FindFile(1)
If datFile = 0 Then
MsgBox "Die *.xlb-Datei wurde nicht gefunden!"
Else
MsgBox "Letztes Änderungsdatum der *.xlb-Datei: " & vbLf & datFile
End If
End Sub