Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
End Sub
Private Sub Items_ItemChange(ByVal Item As Object)
Dim Appt As Outlook.AppointmentItem
If TypeOf Item Is Outlook.AppointmentItem Then
Set Appt = Item
If Appt.ResponseStatus = olResponseAccepted Then
Appt.Categories = "zugesagt"
Appt.Save
End If
If Appt.ResponseStatus = olResponseDeclined Then
Appt.Categories = "abgelehnt"
Appt.Save
End If
If Appt.ResponseStatus = olNotResponded Then
Appt.Categories = "nicht zugesagt"
Appt.Save
End If
If Appt.ResponseStatus = olResponseTentative Then
Appt.Categories = "mit Vorbehalt"
Appt.Save
End If
If Appt.ResponseStatus = olResponseOrganized Then
Appt.Categories =
Appt.Save
End If
End If
End Sub