ganztägige Termine in Outlook setzen aus Excel-Liste heraus
#1
Hallo,

mit folgendem Code erstelle ich ganztägige Geburtstagstermine im Outlook-Kalender.
Leider werden die Termine nicht auf jährliche Wiederholung eingestellt, sondern kommen immer wöchentlich.
Was kann ich tun?

Option Explicit

Sub AddBirthdaysToOutlook()
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim CalendarFolder As Object
    Dim BirthdayItem As Object
    Dim RecurrencePattern As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim birthdayDate As Date

    ' Setze das Arbeitsblatt (hier wird das aktive Blatt verwendet)
    Set ws = ThisWorkbook.ActiveSheet

    ' Erstelle eine Instanz von Outlook
    On Error Resume Next
    Set OutlookApp = GetObject(Class:="Outlook.Application")
    If Err.Number <> 0 Then
        Set OutlookApp = CreateObject(Class:="Outlook.Application")
    End If
    On Error GoTo 0

    ' Zugriff auf den Kalenderordner
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set CalendarFolder = OutlookNamespace.GetDefaultFolder(9) ' 9 steht für den Kalender

    ' Bestimme die letzte Zeile mit Daten in Spalte B und C
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row

    ' Durchlaufe die Liste der Geburtstage
    For i = 2 To lastRow ' Beginne bei 2, um die Überschrift zu überspringen
        If IsDate(ws.Cells(i, "F").Value) Then
            birthdayDate = ws.Cells(i, "F").Value

            ' Erstelle einen neuen Termin im Kalender
            Set BirthdayItem = CalendarFolder.Items.Add(1) ' 1 steht für einen Termin

            With BirthdayItem
                .Subject = " * " & ws.Cells(i, "E").Value & " (" & Year(ws.Cells(i, "F").Value) & ")"
                .Start = DateSerial(Year(Date), Month(birthdayDate), Day(birthdayDate))
                .body = "Geburtstag"
                .AllDayEvent = True

                ' Erstelle das Wiederholungsmuster für den Geburtstagstermin
                Set RecurrencePattern = .GetRecurrencePattern()
                With RecurrencePattern
                    .RecurrenceType = 1 ' Jährlich (olRecursYearly)
                    .Interval = 1 ' Alle Jahre (jährlich)
                    .PatternStartDate = DateSerial(Year(Date), Month(birthdayDate), Day(birthdayDate))
                    .PatternEndDate = DateSerial(Year(Date) + 10, Month(birthdayDate), Day(birthdayDate)) ' Optional: Enddatum für die Wiederholung festlegen (z.B. nach 10 Jahren)
                End With

                .Sensitivity = 2 ' Sensitivity auf privat setzen (olPrivate)

'                .display
                .Save
            End With

            Set BirthdayItem = Nothing
            Set RecurrencePattern = Nothing
        End If
    Next i

    MsgBox "Alle Geburtstage wurden erfolgreich zum Kalender hinzugefügt!", vbInformation

End Sub


VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Beispieldatei

.xlsb   2025-01-01 - Beschäftigten-Liste Geburtstage.xlsb (Größe: 21,56 KB / Downloads: 4)
Antworten Top
#2
Hi,

änder diese Zeile...
.RecurrenceType = 1 ' Jährlich (olRecursYearly)
...um in
.RecurrenceType = 5 ' Jährlich (olRecursYearly)

Lösch diese Zeile...
.Interval = 1 ' Alle Jahre (jährlich)
...komplett

Und lies dir das hier mal durch:
https://docu.combit.net/crm/12/de/sdk/in...cetype.htm

Bei mir wird ein Geb.datum nun nur 1 mal pro Jahr angezeigt.

Ciao
Thorsten
[-] Folgende(r) 1 Nutzer sagt Danke an Oberschlumpf für diesen Beitrag:
  • Rabe
Antworten Top
#3
Hi Thorsten,

das ist ja super. Funktioniert genau so, wie es soll.
Danke !

Warum sagen die dann, da muß 1 stehen?

Das muß ich gleich morgen rückmelden!

Gruß
Ralf
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste