Userform med kalender til valg af datoer

Private Sub UserForm_Initialize()
'Denne procedure eksekverer før formularen åbner.
Dim ctl As Control               'Userform control variabel
Dim lCount As Long               'Tæller
Dim InputLblEvt As clLabelClass  'Midlertidig klasse

On Error GoTo ErrorHandle

'De to collections, colLabelEvent og colLabels
'er deklareret i Module1.
'colLabelEvent er en collection af klasser,
'clLabelClasses, som kontrollerer, hvad der sker,
'når brugeren klikker på en dato-label.
'colLabels er en collection af formularens
'dato-labels og bruges bl.a. til at sætte properties,
'fx at sætte blå ramme omkring den valgte dato.
Set colLabelEvent = New Collection
Set colLabels = New Collection

'Gennemløb dato-labels i Frame1
'og føj dem til de to collections.
For Each ctl In Frame1.Controls
   'Hvis kontrolelementet er en label
   If TypeOf ctl Is MSForms.Label Then
      'Så lav et nyt eksemplar af clLabelClass
      Set InputLblEvt = New clLabelClass
      
      'og knyt det til denne Label
      Set InputLblEvt.InputLabel = ctl
      
      'som vi føjer til colLabelEvent.
      'Ethvert klik på en dato-label i Frame1
      'vil nu blive behandlet af klassen,
      'fordi den deklarerer:
      'Public WithEvents InputLabel As MSForms.Label
      'På den måde undgår vi at skrive klik-events for
      'hver eneste label.
      colLabelEvent.Add InputLblEvt
      
      'Den føjes også til samlingen, colLabels
      colLabels.Add ctl, ctl.Name
   End If
Next

'Vi har ikke længere brug for klassen InputLblEvent
'og sætter den til Nothing for at spare hukommelse.
Set InputLblEvt = Nothing

'Tilføj månedsnavne til måneds-comboboksen.
'Ved at bruge VBA-funktionen MonthName 
'bruges automatisk det sprog, som er valgt 
'i systemindstillingen.
For lCount = 1 To 12
   With cmbMonth
      .AddItem MonthName(lCount)
   End With
Next

'Tilføj år til årstals-comboboksen. VBA håndterer
'ikke år før 1900, hvis der skal regnes o.l..
For lCount = 1900 To Year(Now) + 100
   With cmbYear
      .AddItem lCount
   End With
Next

'Ugedags-labels med lokale indstillinger (første dag
'i ugen) og sprog.
'Hvis landet fx er USA og sproget engelsk, vil den første
'dag i ugen være søndag, og fra venstre mod højre vil der
'stå flg. på mærkaterne:
'"SU" "MO" "TU" "WE" "TH" "FR" "SA"
'VBA-funktionen StrConv(String,1) konverterer til store
'bogstaver. UCase kan også bruges.
lblDay1.Caption = StrConv(Left(WeekdayName(1, , vbUseSystemDayOfWeek), 2), 1)
lblDay2.Caption = StrConv(Left(WeekdayName(2, , vbUseSystemDayOfWeek), 2), 1)
lblDay3.Caption = StrConv(Left(WeekdayName(3, , vbUseSystemDayOfWeek), 2), 1)
lblDay4.Caption = StrConv(Left(WeekdayName(4, , vbUseSystemDayOfWeek), 2), 1)
lblDay5.Caption = StrConv(Left(WeekdayName(5, , vbUseSystemDayOfWeek), 2), 1)
lblDay6.Caption = StrConv(Left(WeekdayName(6, , vbUseSystemDayOfWeek), 2), 1)
lblDay7.Caption = StrConv(Left(WeekdayName(7, , vbUseSystemDayOfWeek), 2), 1)

'Giv dato-mærkaterne en label fra 1 til 42. Tag'en bruges af clLabelClass
'til at tjekke, om en dato er i den aktive måned, forrige eller næste.
With colLabels
   For lCount = 1 To .Count
      .Item(lCount).Tag = lCount
   Next
End With

'LabelCaptions proceduren arrangerer kalenderens
'udseende på grundlag af måned og år.
LabelCaptions Month(Now), Year(Now)

'Mulige datoformater
With cmbDateFormat
   .AddItem Format(Now, "Long Date")
   .AddItem Format(Now, "Medium Date")
   .AddItem Format(Now, "Short Date")
   .Text = Format(Now, "Short Date")
End With

'Find systemindstilling for rækkefølge af dag og måned.
lDayPos = Day("01-02-03")
lMonthPos = Month("01-02-03")

Exit Sub
ErrorHandle:
MsgBox Err.Description
End Sub

Sub LabelCaptions(lMonth As Long, lYear As Long)
Dim lCount As Long            'Tæller
Dim lNumber As Long           'Tæller
Dim lMonthPrev As Long        'Forrige måned
Dim lDaysPrev As Long         'Dage i forrige måned
Dim lYearPrev As Long         'Forrige år

'Få månedens navn baseret på månedsnummer
sMonth = MonthName(lMonth)

'Gem månedsnummeret i variabel
lSelMonth = lMonth

'Gem år i variabel
lSelYear = lYear

'Forbered at få antal dage i forrige måned
Select Case lMonth
   Case 2 To 11
      lMonthPrev = lMonth - 1
      lYearPrev = lYear
   Case 1
      lMonthPrev = 12
      lYearPrev = lYear - 1
   Case 12
      lMonthPrev = 11
      lYearPrev = lYear
End Select

'Antal dage i måned (funktionskald - se senere)
lDays = DaysInMonth(lMonth, lYear)
'Dage i forrige måned
lDaysPrev = DaysInMonth(lMonthPrev, lYearPrev)

'Hvis det er januar 1900 gøres tilbage-knappen passiv.
If lSelYear >= 1900 And lSelMonth > 1 Then
   lblBack.Enabled = True
ElseIf lSelYear = 1900 And lSelMonth = 1 Then
   lblBack.Enabled = False
End If

'Hvis kaldet af denne procedure ikke blev udløst
'af et valg i combo-boksene for måned/år.
If bCmbSel = False Then
   cmbMonth.Text = sMonth
   cmbYear.Text = lYear
End If

'Find månedens første dato.
lFirstDayInMonth = DateSerial(lSelYear, lSelMonth, 1)

'Find datoens ugedagsnummer ved at bruge systemindstillingen for
'første dag i ugen. Vi skal vide, om det er mandag osv. for at
'kunne placere månedens første dag det rigtige sted i ugen.
'Første dag i ugen kan variere fra land til land. I USA er det
'søndag, Danmark bruger mandag.
'Vi bruger vbUseSystemDayOfWeek til at fiske systemindstillingen.
lFirstDayInMonth = Weekday(lFirstDayInMonth, vbUseSystemDayOfWeek)

If lFirstDayInMonth = 1 Then
   lStartPos = 8
Else
   lStartPos = lFirstDayInMonth
End If

'Dage fra forrige måned, hvis månedens første dag ikke er mandag.
lNumber = lDaysPrev + 1
For lCount = lStartPos - 1 To 1 Step -1
   lNumber = lNumber - 1
   With colLabels.Item(lCount)
      .Caption = lNumber
      .ForeColor = &HE0E0E0
   End With
Next

'Dato-labels for den aktive/valgte måned.
lNumber = 0
For lCount = lStartPos To lDays + lStartPos - 1
   lNumber = lNumber + 1
   With colLabels.Item(lCount)
      .Caption = lNumber
      .ForeColor = &H80000012
   End With
Next

'Dato-labels for næste måned
lNumber = 0
For lCount = lDays + lStartPos To 42
   lNumber = lNumber + 1
   With colLabels.Item(lCount)
      .Caption = lNumber
      .ForeColor = &HE0E0E0
   End With
Next

End Sub

Function DaysInMonth(lMonth As Long, lYear As Long) As Long

'Antal dage i måneden
Select Case lMonth
   Case 1, 3, 5, 7, 8, 10, 12
      DaysInMonth = 31
   Case 2
      'Skudår?
      If IsDate("29/2/" & lYear) = False Then
         DaysInMonth = 28
      Else
         DaysInMonth = 29
      End If
   Case Else
      DaysInMonth = 30
End Select

End Function

Option Explicit

'Ved at deklarere Public WithEvents kan vi håndtere
'hændelser "kollektivt". I dette tilfælde er det klik
'på en dato-label, og ved at gøre det på denne måde
'undgår vi at skulle skrive klik-procedurer for hver
'eneste dato-label.
Public WithEvents InputLabel As MSForms.Label
Private Sub InputLabel_click()

'Den valgte dag skifter udseende
With InputLabel
   'Hvis forrige måned
   If .Tag < lStartPos Then
      If UserForm1.lblBack.Enabled = True Then
         UserForm1.lblBack_Click
      End If
      Exit Sub
   End If
   If .Tag > lDays + lStartPos - 1 Then
      UserForm1.lblForward_Click
      Exit Sub
   End If
   'Hvis allerede valgt, hopper vi ud
   If .BorderColor = vbBlue Then Exit Sub
   
   .BorderColor = vbBlue
   .BorderStyle = fmBorderStyleSingle

   'Hvis en anden dag var valgt før denne,
   'får den "normalt" udseende - altså den blå
   'ramme fjernes.
   If Len(sActiveDay) > 0 Then
      If sActiveDay <> InputLabel.Name Then
         With colLabels.Item(sActiveDay)
            .BorderColor = &H8000000E
            .BorderStyle = fmBorderStyleNone
         End With
      End If
   End If
   sActiveDay = InputLabel.Name
   lFirstDay = Val(InputLabel.Caption)
   
   'Hvis dato nummer 2 ikke er valgt
   If bSecondDate = False Then
      UserForm1.FillFirstDay
   Else
      'Hvis det er dato nummer 2
      UserForm1.FillSecondDay
   End If
End With

End Sub