hier ist sie
https://www.herber.de/bbs/user/27827.xls
hier der "komplette Code" der Kalender-Userform
Option Explicit
Dim dateVon As Date
Dim dateBis As Date
Dim frstDay As Integer
Dim lstDay As Integer
Dim monat As Integer
Dim jahr As Integer
Dim aktuelleNr As Byte 'Um wiederholtes Aufrufen der ToggleAction zu verhindern
Dim tb As Integer
Dim x As Integer
Private Sub UserForm_Initialize()
Dim nDay As Integer
Dim i As Integer
'.....Monate in Combobox2 eintragen
For x = 1 To 12
ComboBox2.AddItem Format(DateSerial(2000, x, 1), "MMMM")
Next x
'.....Jahre in Combobox3 eintragen
For x = 2000 To 2222
ComboBox3.AddItem x
Next x
'.....Aktuelles Datum als Startwerte setzen
ComboBox2.ListIndex = Month(Date) - 1
ComboBox3.ListIndex = 3
frstDay = Weekday(DateSerial(Year(Date), Month(Date), 1), 2)
lstDay = frstDay + Day(DateSerial(Year(Date), Month(Date) + 1, 0))
monat = ComboBox2.ListIndex + 1
jahr = ComboBox3.ListIndex
For i = 1 To 42
With Controls("ToggleButton" & i)
.Visible = False
.Value = False
.BackColor = &H8000000F
.ForeColor = &H800000
End With
With Controls("Label" & i)
.Visible = False
End With
Next i
For nDay = 1 To Day(DateSerial(Year(Date), Month(Date) + 1, 0))
Controls("ToggleButton" & nDay + frstDay - 1).Caption = nDay
Controls("ToggleButton" & nDay + frstDay - 1).Visible = True
Next nDay
'......AKTUELLER TAG MARKIEREN !
With Controls("ToggleButton" & Day(Date) + frstDay - 1)
.Value = True
'.BackColor = &H8000000D
.ForeColor = &HFFFF&
.BackStyle = 0
End With
With Controls("Label" & Day(Date) + frstDay - 1)
.Visible = True
End With
'Aktivierter Tag (tb.caption)ermitteln:
tb = 1
Do Until Controls("ToggleButton" & tb).Value = True
tb = tb + 1
Loop
Label43.Caption = Format(DateSerial(Year(Date), Month(Date), Day(Date)), "mmmm") & " " & Year(Date)
End Sub
Private Sub ComboBox2_Change()
Dim nDay As Integer
Dim i As Integer
monat = ComboBox2.ListIndex + 1
jahr = ComboBox3.ListIndex
frstDay = Weekday(DateSerial(jahr, monat, 1), 2)
lstDay = frstDay + Day(DateSerial(jahr, monat + 1, 0))
For i = 1 To 42
With Controls("ToggleButton" & i)
.Visible = False
.Value = False
.BackColor = &H8000000F
.ForeColor = &H800000
End With
With Controls("Label" & i)
.Visible = False
End With
Next i
For nDay = 1 To Day(DateSerial(jahr, monat + 1, 0))
Controls("ToggleButton" & nDay + frstDay - 1).Caption = nDay
Controls("ToggleButton" & nDay + frstDay - 1).Visible = True
Controls("ToggleButton" & nDay + frstDay - 1).Value = False
Controls("Label" & nDay + frstDay - 1).Visible = True
Next nDay
Label43.Caption = Format(DateSerial(jahr, monat, 1), "mmmm") & " " & Format(DateSerial(jahr, monat, 1), "yyyy")
End Sub
Private Sub ComboBox3_Change()
Dim nDay As Integer
Dim i As Integer
monat = ComboBox2.ListIndex + 1
jahr = ComboBox3.ListIndex
frstDay = Weekday(DateSerial(jahr, monat, 1), 2)
lstDay = frstDay + Day(DateSerial(jahr, monat + 1, 0))
For i = 1 To 42
With Controls("Togglebutton" & i)
.Visible = False
.Value = False
.BackColor = &H8000000F
.ForeColor = &H800000
End With
With Controls("Label" & i)
.Visible = False
End With
Next i
For nDay = 1 To Day(DateSerial(jahr, monat + 1, 0))
Controls("ToggleButton" & nDay + frstDay - 1).Caption = nDay
Controls("ToggleButton" & nDay + frstDay - 1).Visible = True
Controls("Label" & nDay + frstDay - 1).Visible = True
Next nDay
Label43.Caption = Format(DateSerial(jahr, monat, 1), "mmmm") & " " & Format(DateSerial(jahr, monat, 1), "yyyy")
End Sub
Private Sub cmdEinfügen_Click()
If TextBox1.Text = "" Then
cmdVon.SetFocus
ElseIf TextBox2.Text = "" Then
cmdBis.SetFocus
Else
dateVon = TextBox1.Text
dateBis = TextBox2.Text
ActiveCell = dateVon
ActiveCell.Offset(0, 1) = dateBis
Unload Me
End If
End Sub
Private Sub cmdAbbrechen_Click()
Unload Me
End Sub
Private Sub cmdBis_Click()
tb = 1
Do Until Controls("ToggleButton" & tb).Value = True
tb = tb + 1
Loop
TextBox2.Text = CDate(Controls("ToggleButton" & tb).Caption & "." & monat & "." & jahr)
End Sub
Private Sub cmdVon_Click()
tb = 1
Do Until Controls("ToggleButton" & tb).Value = True
tb = tb + 1
Loop
TextBox1.Text = CDate(Controls("ToggleButton" & tb).Caption & "." & monat & "." & jahr)
End Sub
Private Sub ToggleButton1_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 1
End Sub
Private Sub ToggleButton2_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 2
End Sub
Private Sub ToggleButton3_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 3
End Sub
Private Sub ToggleButton4_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 4
End Sub
Private Sub ToggleButton5_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 5
End Sub
Private Sub ToggleButton6_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 6
End Sub
Private Sub ToggleButton7_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 7
End Sub
Private Sub ToggleButton8_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 8
End Sub
Private Sub ToggleButton9_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 9
End Sub
Private Sub ToggleButton10_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 10
End Sub
Private Sub ToggleButton11_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 11
End Sub
Private Sub ToggleButton12_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 12
End Sub
Private Sub ToggleButton13_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 13
End Sub
Private Sub ToggleButton14_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 14
End Sub
Private Sub ToggleButton15_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 15
End Sub
Private Sub ToggleButton16_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 16
End Sub
Private Sub ToggleButton17_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 17
End Sub
Private Sub ToggleButton18_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 18
End Sub
Private Sub ToggleButton19_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 19
End Sub
Private Sub ToggleButton20_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 20
End Sub
Private Sub ToggleButton21_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 21
End Sub
Private Sub ToggleButton22_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 22
End Sub
Private Sub ToggleButton23_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 23
End Sub
Private Sub ToggleButton24_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 24
End Sub
Private Sub ToggleButton25_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 25
End Sub
Private Sub ToggleButton26_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 26
End Sub
Private Sub ToggleButton27_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 27
End Sub
Private Sub ToggleButton28_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 28
End Sub
Private Sub ToggleButton29_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 29
End Sub
Private Sub ToggleButton30_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 30
End Sub
Private Sub ToggleButton31_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 31
End Sub
Private Sub ToggleButton32_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 32
End Sub
Private Sub ToggleButton33_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 33
End Sub
Private Sub ToggleButton34_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 34
End Sub
Private Sub ToggleButton35_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 35
End Sub
Private Sub ToggleButton36_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 36
End Sub
Private Sub ToggleButton37_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 37
End Sub
Private Sub ToggleButton38_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 38
End Sub
Private Sub ToggleButton39_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 39
End Sub
Private Sub ToggleButton40_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 40
End Sub
Private Sub ToggleButton41_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 41
End Sub
Private Sub ToggleButton42_Click()
If aktuelleNr <> 0 Then Exit Sub
ToggleAction 42
End Sub
Sub ToggleAction(nr As Byte)
Dim obj As Object
'
For Each obj In frmKalender.Controls
'Wenn es ein ToggleButton ist....
If Left(obj.Name, 12) = "ToggleButton" Then
aktuelleNr = nr 'Aufruf der anderen Toggles verhindern
'Wenn es der gewünschte Toggle ist
If obj.Name = "ToggleButton" & nr Then
'setze Atribute
If obj.Value = True Then
obj.BackColor = &H8000000D
obj.ForeColor = &HFFFF&
obj.Font.Size = 10
obj.Font.Bold = True
obj.BackStyle = 0
With Controls("Label" & nr)
.Visible = True
End With
Else
obj.Value = True '+++++++
obj.BackColor = &H8000000D
obj.ForeColor = &HFFFF&
obj.Font.Size = 10
obj.Font.Bold = True
obj.BackStyle = 0
With Controls("Label" & nr)
.Visible = True
End With
End If
Else
'wenn es nicht der gewünschter Toggle ist
obj.Value = False
obj.BackColor = &H8000000F
obj.ForeColor = &H800000
obj.Font.Size = 8
obj.Font.Bold = False
obj.BackStyle = 1
With Controls("Label" & nr)
.Visible = True
End With
End If
End If
Next obj
aktuelleNr = 0 'Aufruf wieder freigeben
End Sub
paula