Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Jahreskalender als Menü anlegen

Gruppe

Bar

Problem

Es soll eine Menüleiste als Jahreskalender mit Monaten als Menüs und Tagen als Menüpunkten gebildet werden.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

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

    

Beiträge aus dem Excel-Forum zu den Themen Menue und Bar