Doppelte und mehrfache Geburtstage aus dem Outlook Kalender automatisch löschen und anschließend automatisch neu eintragen.

Sub DeleteAllBirthdaysFromDefaultCalendar()
    Dim folderCalendar As Folder, birthdays As items
    Set folderCalendar = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)  
    Set birthdays = folderCalendar.items.Restrict("@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001E"" like 'Geburtstag von%' AND ""http://schemas.microsoft.com/mapi/id/{00062002-0000-0000-C000-000000000046}/82310003"" = 4")  
    While birthdays.count > 0
        birthdays.Remove 1
    Wend
End Sub

Sub RecreateBirthdays()
    Dim folderContacts As Folder, contact As Object, folderCalendar as Folder
    Set folderContacts = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)  
    Set folderCalendar = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)  
   
    For Each contact In folderContacts.items.Restrict("@SQL=NOT ""http://schemas.microsoft.com/mapi/proptag/0x3A420040"" IS NULL")  
            If contact.CLASS = olContact Then
                Dim entry As AppointmentItem
                Set entry = folderCalendar.items.add(olAppointmentItem)
                entry.AllDayEvent = True
                entry.Subject = "Geburtstag von " & contact.FullName  
                entry.ReminderMinutesBeforeStart = 1440
                entry.ReminderSet = True
                Dim opattern As RecurrencePattern
                Set opattern = entry.GetRecurrencePattern
                With opattern
                    .RecurrenceType = olRecursYearly
                    .DayOfMonth = DateTime.Day(contact.Birthday)
                    .MonthOfYear = DateTime.Month(contact.Birthday)
                    .NoEndDate = True
                End With
                entry.Save
            End If
    Next
End Sub