Gruppe
Menue
Problem
Es soll eine Menüleiste als Jahreskalender mit Monaten als Menüs und Tagen als Menüpunkten gebildet werden.
StandardModule: Modul1
Sub NewMenue()
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 Resume Next
Application.CommandBars(CStr(Year(Date))).Delete
On Error GoTo 0
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 DeleteMenue()
On Error Resume Next
Application.CommandBars(CStr(Year(Date))).Delete
On Error GoTo 0
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