In Outlook (Exchange) Serientermin erstellen
Michael Grenzheuser
Hallo,
könnte mir jemenad helfen?
Ich bin gerade dabei, dass ich in Outlook einen Kalendereintrag "Geburtstage" anlegen kann.
Der Kalender ist in Exchange freigegeben und kann auch angesprochen und der Termin eingetragen werden.
Leider bekomme ich es nicht hin, dass sich der Termin ab Startdatum jährlich wiederholt.
Was mache ich falsch?
Vielen Dank für eure Hilfe
PS: im Internet findet man dazu eine Lösung, aber die geht nur auf den persönlichen Kalender und nicht auf einen freigegebenen Kalender unter Exchange.
Private Sub CommandButton1_Click()
Dim objOutlook As Outlook.Application
Dim objNameSpace As Object
Dim objFolder As Object
Dim objDummy As Object
Dim objRecipient As Object
Dim objAppt As Object
Dim OutPattern As RecurrencePattern
Dim TestDatum as String
TestDatum = "18.04.2024"
'------------- Abfrage, ob Outlook vorhanden ist ---------------------------
On Error Resume Next
Set objOutlook = GetObject("", "Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
On Error Resume Next
Set objOutlook = GetObject("Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
Else
Set objOutlook = Nothing
End If
End If
'------------- Abfrage, ob Geb-Datum ausgefüllt ist -----------------------------
If MsgBox("Möchten Sie wirklich an den Geburtstag erinnert werden?", vbYesNo) = vbYes Then
'------------- bestimmter anderer Kalender festlegen -----------------------
strName = "GebTag" 'internal mail address (Exchange) - Name vom Kalender
'------------- Definitionen ------------------------------------------------
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objDummy = objOutlook.CreateItem(olAppointmentItem)
Set objRecipient = objDummy.Recipients.Add(strName)
objRecipient.Resolve
'------------- In Kalender eintragen ---------------------------------------
If objRecipient.Resolved Then
Set objFolder = objNameSpace.GetSharedDefaultFolder(objRecipient, olFolderCalendar)
If Not objFolder Is Nothing Then
Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
'set default appointment values
.MeetingStatus = olMeeting
.AllDayEvent = True
.Subject = "Geburtstag von: "
.Location = "(wird bekannt gegeben)"
.Body = "in Outlook eingetragen am: " & Date
.Start = TestDatum
'.Resources = ""
.Categories = "Geburtstage"
.ReminderMinutesBeforeStart = 120
.ReminderPlaySound = True
.ReminderSet = True
'In Serientermin umwandeln
Set OutPattern = objDummy.GetRecurrencePattern
With OutPattern
.RecurrenceType = olRecursYearly
'.PatternStartDate = .Start
'.PatternStartDate = TestDatum
'.Duration = 1440
'.Interval = 1
'.Occurrences = 3
.NoEndDate = True
End With
.Save
.Display True
End With
End If
End If
Else
MsgBox "Der Kalender " & Chr(34) & strName & Chr(34) _
& " konnte nicht gefunden werden!", vbCritical, "Kalender nicht gefunden"
End If
End if
'------------- alles zurücksetzen ------------------------------------------
Set objOutlook = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecipient = Nothing
Set objAppt = Nothing
'------------- Erfolgsmeldung ----------------------------------------------
MsgBox "Der Termin wurden erfolgreich in den Kalender " & Chr(34) & strName & Chr(34) _
& " eingetragen!", vbInformation, "Erfolgreich eingetragen"
End If
End If
End Sub