Gruppe
Menue
Bereich
Context
Thema
Zellkontextmenü durch Jahreskalender ersetzen
Problem
Wie kann ich das Zellkontextmenü durch den Kalender des aktuellen Jahres ersetzen? Bei Anklicken eines Tages soll das ausgewählte Datum in die aktive Zelle eingetragen werden.
Lösung
Geben Sie den Ereigniscode in das Klassenmodul der Arbeitsmappe ein.
ClassModule: DieseArbeitsmappe
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call CmdDelete
End Sub
Private Sub Workbook_Open()
Dim oBar As CommandBar
Dim oCntr As CommandBarControl
Dim oBtn As CommandBarButton
Dim iMonth As Integer, iDay As Integer
Call CmdDelete
Set oBar = Application.CommandBars.Add("Datum", msoBarPopup)
Set oBtn = oBar.Controls.Add
With oBtn
.Caption = Year(Date)
.Style = msoButtonCaption
End With
For iMonth = 1 To 12
Set oCntr = oBar.Controls.Add(msoControlPopup)
oCntr.Caption = Format(DateSerial(Year(Date), iMonth, 1), "mmmm")
If iMonth = 1 Then oCntr.BeginGroup = True
For iDay = 1 To Day(DateSerial(Year(Date), iMonth + 1, 0))
Set oBtn = oCntr.Controls.Add
With oBtn
.Caption = iDay
.Style = msoButtonCaption
.OnAction = "Kalender"
End With
Next iDay
Next iMonth
End Sub
StandardModule: basMain
Sub Kalender()
ActiveCell.NumberFormat = "dd.mm.yyyy"
With CommandBars("Datum")
ActiveCell.Value = DateSerial(.Controls(1).Caption, _
Application.Caller(2) - 2, Application.Caller(1))
End With
End Sub
Sub CmdDelete()
On Error GoTo ERRORHANDLER
Application.CommandBars("Datum").Delete
ERRORHANDLER:
End Sub
ClassModule: Tabelle1
Private Sub Worksheet_BeforeRightClick( _
ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.CommandBars("Datum").ShowPopup
End Sub