Selber gelöst!
Mit ein bisschen Hilfe aus einem anderen Forum habe ich mir die Lösung selbst erarbeitet. Natürlich will ich sie euch nicht vorenthalten!
Hier ist sie:
Sub geburtstage_eintragen()
Dim NeuerGeburtstag As Outlook.AppointmentItem
Dim objContactItem As Outlook.ContactItem
Dim objApp As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim Datum As Date
Set objApp = New Outlook.Application
Set objNameSpace = objApp.GetNamespace(Type:=„MAPI“)
’ Der Kontaktordner, aus dem Geburtstage ausgelesen werden
Dim CRMKontakte As Outlook.MAPIFolder
Set CRMKontakte = objNameSpace.GetDefaultFolder(FolderType:=olFolderContacts).Folders(„CRM“)
’ Der Kalenderordner, in den Geburtstage eingetragen werden
’ Achtung: Nur für Termine im Hauptordner wird eine Erinnerung ausgegeben
Dim GebKalender As Outlook.MAPIFolder
Set GebKalender = objNameSpace.GetDefaultFolder(FolderType:=olFolderCalendar) '.Folders(„Geburtstage“)
’ Geburtstage eintragen
For Each objContactItem In CRMKontakte.Items()
Set NeuerGeburtstag = GebKalender.Items.Add(olAppointmentItem)
With NeuerGeburtstag
.Start = objContactItem.Birthday
.AllDayEvent = True
Set wiederkehr = NeuerGeburtstag.GetRecurrencePattern
wiederkehr.RecurrenceType = olRecursYearly
.Subject = objContactItem.Subject + " Geburtstag (aus CRM-Kontakt)"
.Body = objContactItem.Categories + „-Kunde“
.ReminderMinutesBeforeStart = 10080
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Next objContactItem
MsgBox Prompt:=„Geburtstage eingetragen!“
End Sub
