Sub CreateCalendar()
Dim TempForm As VBComponent
Dim NewBox As MSForms.ComboBox
Dim NewLab As MSForms.Label
Dim NewBut As MSForms.CommandButton
Dim NewMult As MSForms.MultiPage
Dim newPage As MSForms.Page
Dim Start As Date, Ende As Date
Dim x%, i%, y%, z%, n%
Dim FormName$
    Application.VBE.MainWindow.Visible = False
    Application.ScreenUpdating = False
    Set TempForm = ThisWorkbook.VBProject.VBComponents _
                               .Add(vbext_ct_MSForm)
    With TempForm
        .Properties("Caption") = "Kalender"
        .Properties("Width") = 300
        .Properties("Height") = 213
    End With
    FormName = TempForm.Name
    Set NewBox = TempForm.Designer.Controls _
                         .Add("Forms.ComboBox.1")
    With NewBox
        .Height = 18
        .Width = 48
        .Left = 54
        .Top = 168
    End With
    With NewBox
        .Style = fmStyleDropDownList
        .Value = Year(Date)
    End With
    Set NewLab = TempForm.Designer.Controls.Add("Forms.Label.1")
    With NewLab
        .Height = 12
        .Width = 36
        .Left = 12
        .Top = 174
        .Caption = "Jahr:"
    End With
    Set NewBut = TempForm.Designer.Controls _
                         .Add("Forms.CommandButton.1")
    With NewBut
        .Height = 24
        .Width = 174
        .Left = 114
        .Top = 162
        .Caption = "Weiter"
    End With
    Set NewMult = TempForm.Designer.Controls.Add("Forms.MultiPage.1")
    With NewMult
        .Height = 150
        .Width = 290
        .Left = 4
        .Top = 5
        .Pages.Clear
        For i = 0 To 11
            Set newPage = .Pages _
                          .Add(Format(DateSerial(Year(Date), _
                          i + 1, 1), "mmm"))
            For y = 1 To 7
                Set NewLab = newPage.Controls.Add("Forms.Label.1")
                With NewLab
                   .Top = 10
                    .Left = 10 + (y - 1) * 38
                    .Width = 38
                    .Height = 15
                    .BackColor = &H8000000F
                    .BackStyle = fmBackStyleOpaque
                    .Font.Name = "Arial"
                    .Font.Bold = True
                    .SpecialEffect = 1
                    .Caption = Format(DateSerial(1998, 11, 15) _
                                               + y - 1, "ddd")
                    .TextAlign = 2
                End With
            Next y
            Start = DateSerial(NewBox.Value, newPage.Index + 1, 1)
            Ende = DateSerial(NewBox.Value, newPage.Index + 2, 0)
            For y = 1 To 6
                For z = 1 To 7
                    n = n + 1
                    Set NewLab = newPage.Controls _
                        .Add("Forms.Label.1")
                    With NewLab
                        .Top = 18 + y * 15
                        .Left = 10 + (z - 1) * 38
                        .Width = 38
                        .Height = 15
                        .BackColor = &H8000000F
                        .BackStyle = fmBackStyleOpaque
                        .Font.Name = "Arial"
                        .SpecialEffect = 1
                        .TextAlign = 2
                    End With
                Next z
            Next y
            x = Weekday(Start)
            For z = 1 To Day(Ende)
                newPage.Controls("Label" & 8 + newPage _
                       .Index * 49 + x + z - 1) = z
            Next z
        Next i
        NewMult.Value = Month(Date) - 1
        For i = 8 + NewMult.Value * (42 + 7) To 8 + _
                    NewMult.Value * (42 + 7) + 41
            With NewMult.Pages(Month(Date) - 1).Controls("Label" & i)
                If .Caption = CStr(Day(Date)) Then
                   .BackColor = RGB(255, 255, 0)
            End With
        Next i
    End With
    With TempForm.CodeModule
        i = .CountOfLines
        If i = 2 Then
            .InsertLines i, "": i = i + 1
        Else
            i = 1
        End If
        .InsertLines i, "Private Sub CommandButton1_Click()": i = i + 1
        .InsertLines i, "    Unload Me": i = i + 1
        .InsertLines i, "End Sub": i = i + 1
        .InsertLines i, "": i = i + 1
        .InsertLines i, "Private Sub UserForm_Initialize()": i = i + 1
        .InsertLines i, "Dim i%": i = i + 1
        .InsertLines i, "    For i = 1900 To 2100": i = i + 1
        .InsertLines i, "        ComboBox1.AddItem i": i = i + 1
        .InsertLines i, "    Next i": i = i + 1
        .InsertLines i, "End Sub": i = i + 1
        .InsertLines i, "": i = i + 1
        .InsertLines i, "Private Sub ComboBox1_Change()": i = i + 1
        .InsertLines i, "Dim Start As Date, Ende As Date": i = i + 1
        .InsertLines i, "Dim i%, n%, x%, y%, z%": i = i + 1
        .InsertLines i, "  For i = 0 To 11": i = i + 1
        .InsertLines i, "    Start = DateSerial(ComboBox1.Value, i + 1, 1)": i = i + 1
        .InsertLines i, "    Ende = DateSerial(ComboBox1.Value, i + 2, 0)": i = i + 1
        .InsertLines i, "    For n = 9 To 50": i = i + 1
        .InsertLines i, "      With MultiPage1.Pages(i).Controls(""Label"" & n + i * 49)": i = i + 1
        .InsertLines i, "        .BackColor = &H8000000F": i = i + 1
        .InsertLines i, "        .Caption = """: i = i + 1
        .InsertLines i, "      End With": i = i + 1
        .InsertLines i, "    Next n": i = i + 1
        .InsertLines i, "    x = Weekday(Start)": i = i + 1
        .InsertLines i, "    For z = 1 To Day(Ende)": i = i + 1
        .InsertLines i, "      With MultiPage1.Pages(i)": i = i + 1
        .InsertLines i, "        .Controls(""Label"" & 8 + .Index * 49 + x + z - 1) = z": i = i + 1
        .InsertLines i, "      End With": i = i + 1
        .InsertLines i, "    Next z": i = i + 1
        .InsertLines i, "  Next i": i = i + 1
        .InsertLines i, "End Sub"
    End With
    VBA.UserForms.Add(FormName).Show
    ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm
End Sub

