AW: Anpassungen genialer Kalender
27.03.2020 19:33:28
Hajo_Zi
Hallo Uwe,
man reicht den kleinen Finger und es muss gleich der ganze Arm sein
Option Explicit ' Variablendefinition erforderlich
Option Private Module ' damit Makros nicht unter dem Punkt Makro _
erscheinen
'* H. Ziplies *
'* 27.03.2020 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de
Public CoTag() As New cls_Tag ' Name für Klasseprogrammierung Tag
Public CoKW() As New cls_Kalenderwoche ' Name für Klasseprogrammierung _
Kalenderwoche
Public DaDatumKa As Date ' Datum Kalender Anfang
Public InI As Integer ' Schleifenvariable, Variable zum _
zusamenfassen Tag
Public InK As Integer ' Schleifenvariable, Variable zum _
zusamenfassen Kalenderwoche
Sub Start()
Frm_Kalender.Show ' UserForm starten
End Sub
Sub Erstellen(DaDatum As Date)
Dim InKwA As Integer ' Variable 1. Kalenderwoche im Monat
Dim InKwE As Integer ' Variable letzte Kalenderwoche im Monat
Dim LoI As Integer ' Schleifenvariable
Dim Ob_Tag As MSForms.Label ' Variable für Objekt als neues Label Tag
Dim Ob_KW As MSForms.Label ' Variable für Objekt als neues Label _
Kalenderwoche
Dim Ob_LaF As MSForms.Label ' Variable für Objekt als neues Label _
Feiertage
Dim LoZaehler As Long ' Zeile Label
Dim LoZaehlerF As Long ' Zeile Feiertage
Dim InJ As Integer ' Schleifenvariable Wochentage
Dim DaAnfang As Date ' Anfangsdatum Kalender
Dim StFeiertag As String ' Variable für Feiertag
Dim BoFeier As Boolean ' Hinweis Bundesland
Dim Ob_St As Object ' Variable Objekte
DaDatumKa = DaDatum ' merken übergebenes Datum für _
Klassenprogramm
LoZaehler = 1 ' Überschriftenzeile schon da
LoZaehlerF = 0 ' Überschriftenzeile schon da
InI = 0 ' Variable für Zählen der Label auf 0 für _
Array
' erster Tag in erster Woche
DaAnfang = DateSerial(Year(DaDatum), Month(DaDatum), 1) - _
Weekday(DateSerial(Year(DaDatum), Month(DaDatum), 1), 2) + 1
' Kalenderwoche für ersten Tag im Monat
InKwA = KALENDERWOCHE_DIN(DateSerial(Year(DaDatum), Month(DaDatum), 1))
' Kalenderwoche für letzten Tag im Monat
InKwE = KALENDERWOCHE_DIN(DateSerial(Year(DaDatum), Month(DaDatum) + 1, 1) - 1)
With Frm_Kalender ' Bezug auf die UserForm
.Cbo_Jahr.Tag = 1 ' damit Erstellen bei Change nicht ausgelö _
st
.Cbo_Monat.Tag = 1 ' damit Erstellen bei Change nicht ausgelö _
st
.Scb_Monat.Tag = 1 ' damit Erstellen bei Change nicht ausgelö _
st
' ScrollBar auf aktuellen Wert setzen
.Scb_Monat = (Year(DaDatum) - 1900) * 12 + Month(DaDatum)
' bei allen Label Beschriftung löschen und Farbe zurücksetzen
.Cbo_Jahr = Year(DaDatum) ' ausgewähltes Jahr anzeigen in ComboBox
.Lbl_Datum = Format(DaDatum, "MMMM YYYY") ' ausgewählten Monat und Jahr anzeigen
' ausgewählten Monat anzeigen in ComboBox
.Cbo_Monat = Format(DateSerial(Year(Date), Month(DaDatum), 1), "MMMM")
For Each Ob_St In .Controls
If TypeName(Ob_St) = "Label" Then
With Ob_St
If Left(.Name, 5) = "Label" Then
.Caption = ""
.BackColor = -2147483633
End If
End With
End If
Next Ob_St
' Schleife Label
For LoI = 1 To 10 ' keine ander Lösung gefunden für _
Jahreswechsel
' Label Kalenderwoche erstellen im Rahmen
Set Ob_KW = .Frm_Rahmen.Controls.Add("Forms.Label.1", "Label" & LoI, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_KW
.Left = 6 ' Position links
.Top = 15 * LoZaehler + 6 ' Position oben
.Width = 25 ' Breite
.Height = 15 ' Höhe
.Font.Bold = True ' Schriftschnitt Fett
' Beschriftung mit der entsprechenden Kalenderwoche
.Caption = KALENDERWOCHE_DIN(DaAnfang + (LoI - 1) * 7)
.TextAlign = fmTextAlignRight
.Tag = .Caption
End With
ReDim Preserve CoKW(0 To InK)
Set CoKW(InK).Label = Ob_KW ' Label zur Klasse zusammenfassen
InK = InK + 1 ' Zähler für das Array Label
' Kalenderwoche
For InJ = 1 To 7
' Label Tag erstellen im Rahmen
Set Ob_Tag = .Frm_Rahmen.Controls.Add("Forms.Label.1", "Label" & LoI & InI, _
True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_Tag
.Left = 6 + InJ * 30 ' Position links
.Top = 15 * LoZaehler + 6 ' Position oben
.Width = 25 ' Breite
.Height = 15 ' Höhe
.Tag = DaAnfang + InI ' Datum
.Caption = Day(DaAnfang + InI) ' Tag
.Tag = DaAnfang + InI
.TextAlign = fmTextAlignRight ' Ausrichtung rechts
' Farbe Wochenende
If DaAnfang + InI = Date Then
.BackColor = 65535
End If
If Weekday(DaAnfang + InI, 2) > 5 Then
.ForeColor = 255
End If
' Farbe für Tage außerhalb des aktuellen Monats
If Month(DaAnfang + InI) Month(DaDatum) Then
.ForeColor = 8421504
End If
If .ForeColor 8421504 Then
If Weekday(DaAnfang + InI, 2) = 1 Then
.BackColor = 65535
End If
End If
' Feiertag
' Feiertag nur im aktuellen Monat
'If Month(DaAnfang) = Month(DaDatum + InI) Then
StFeiertag = Feiertag(DaAnfang + InI)
'End If
If StFeiertag "" Then
.BackColor = 13434828 ' Hintergrundfarbe ändern
End If
' Label zusammenfassen
' Neudimensionierung des Array
ReDim Preserve CoTag(0 To InI)
Set CoTag(InI).Label = Ob_Tag ' Label zur Klasse zusammenfassen
InI = InI + 1 ' Zähler für das Array Label
End With
' Feiertage auflisten im 2. Rahmen
If StFeiertag "" And Month(DaAnfang + InI) = Month(DaDatum) Then
Set Ob_LaF = .Frm_Rahmen2.Controls.Add("Forms.Label.1", "LabelF" & _
LoZaehlerF, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_LaF ' Bezug auf das erstelle Label
.Left = 6 ' Position links
.Top = 15 * LoZaehlerF + 6 ' Position oben
.Width = 238 ' Breite
.Height = 15 ' Höhe
' Beschriftung mit Feiertag
.Caption = " " & DaAnfang + InI - 1 & " " & StFeiertag
.TextAlign = fmTextAlignLeft
.BackColor = 13434828 ' Hintergrundfarbe Grün
' prüfen ob Bundesland abhängiger Feiertag
If InStr(StFeiertag, "*") > 0 Then BoFeier = True
End With
LoZaehlerF = LoZaehlerF + 1 ' Zeilenzähler Feiertage erhöhen
End If
Next InJ
LoZaehler = LoZaehler + 1 ' Zeilenzähler Kalenderwoche erhöhen
' Schleife verlassen, wenn Montag im nächsten Monat
If Month(DaAnfang + LoI * 7) Month(DaDatum) Then Exit For
Next LoI
If BoFeier Then ' es gibt Feiertage Bundesland abhängig
Set Ob_LaF = .Frm_Rahmen2.Controls.Add("Forms.Label.1", "LabelF" & LoZaehlerF + 1, _
True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_LaF ' Bezug auf das erstellte Label
.Left = 6 ' Position links
.Top = 15 * LoZaehlerF + 6 ' Position oben
.Width = 238 ' Breite
.Height = 15 ' Höhe
' Hinweis Feiertag
.Caption = " * Feiertag Bundesland abhängig"
.TextAlign = fmTextAlignLeft ' Ausrichtung
.BackColor = 13434828 ' Hintergrundfarbe Grün
End With
LoZaehlerF = LoZaehlerF + 1
End If
' Rahmenhöhe Rahmen2
.Frm_Rahmen.Height = 15 * LoZaehler + 16
If LoZaehlerF = 0 Then
.Frm_Rahmen2.Height = 0 ' Rahmenhöhe 0, da kein Eintrag
Else
' Rahmenhöhe und Position Rahmen2
.Frm_Rahmen2.Height = 15 * LoZaehlerF + 16
.Frm_Rahmen2.Top = .Frm_Rahmen.Height + 65
End If
' UserFormhöhe
.Height = .Frm_Rahmen.Height + .Frm_Rahmen2.Height + 95
.Cbo_Jahr.Tag = "" ' zurücksetzen damit Erstellen bei Change _
ausgelöst wird
.Cbo_Monat.Tag = "" ' zurücksetzen damit Erstellen bei Change _
ausgelöst wird
.Scb_Monat.Tag = "" ' zurücksetzen damit Erstellen bei Change _
ausgelöst wird
End With
Set Ob_Tag = Nothing ' Variablen leeren
Set Ob_LaF = Nothing ' Variablen leeren
End Sub
Option Explicit ' Variablendefinition erforderlich
'* H. Ziplies *
'* 27.03.2020 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de
Public WithEvents Label As MSForms.Label
Private Sub Label_Click()
If Label.ForeColor 8421504 Then
If Month(Label.Tag) = Month(DaDatumKa) Then
If Weekday(CDate(Label.Tag), 2) = 1 Then
Range("B10") = DateValue(Label.Tag) ' Tag in Zelle
Range("B10").NumberFormat = "dd.mm.yy" ' Zellformat Standard
Unload Frm_Kalender ' UseerForm verlassen
Else
MsgBox "Flasches Datum"
End If
Else
Erstellen Label.Tag ' ausgewählten Monat anzeigen
End If
End If
End Sub
Gruß Hajo