Sub TEST_SerialAppointment()
'---------------------------------------------------------------------
' Purpose: Creating a serial appointment in a specific calendar
'---------------------------------------------------------------------
Dim oOutlook            As Outlook.application
Dim oNameSpace          As Outlook.NameSpace
Dim oCalendar           As Outlook.Folder
Dim oMyCalendar         As Outlook.Folder
Dim oAppointment        As Outlook.AppointmentItem
Dim datStart            As Date
Const datBirthday       As Date = "03/10/2001"

    'the pattern shall start from today
    datStart = DateSerial(Year(Date), Month(datBirthday), Day(datBirthday))
    ' create Outlook-Application-Objekt
    Set oOutlook = CreateObject("Outlook.Application")
    ' Namespace
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    'Standard Calendar
    Set oCalendar = oNameSpace.GetDefaultFolder(olFolderCalendar)
    'My Calendar where the entry shall be made
    Set oMyCalendar = oNameSpace.GetDefaultFolder(olFolderCalendar).Folders("student (Nur dieser Computer)")
    'Entry
    Set oAppointment = oMyCalendar.Items.Add

    With oAppointment
        .GetRecurrencePattern.RecurrenceType = olRecursYearly
        .GetRecurrencePattern.Occurrences = 5
        .GetRecurrencePattern.Duration = 24 * 60
        .GetRecurrencePattern.PatternStartDate = datStart
        .GetRecurrencePattern.StartTime = 0
        .GetRecurrencePattern.EndTime = 0
        .Subject = "Test_entry"
        .Body = "test"
        .BusyStatus = olFree
        .Categories = "Test"
        .Location = "location"
        .AllDayEvent = True
        .ReminderMinutesBeforeStart = 24 * 60
        .Duration = 24 * 60
        .Save
        .Display
    End With
    
On Error Resume Next
Set oOutlook = Nothing
Set oNameSpace = Nothing
Set oCalendar = Nothing
Set oMyCalendar = Nothing
Set oAppointment = Nothing
End Sub