' Serien-Kalendereinträge aus Excel erstellen mit Serienlogik, Löschung alter Einträge und Logging

Sub SerienKalendereintraegeErstellen()
    Dim olApp As Object, olNS As Object
    Dim allCalendars As Collection, selectedCalendar As Object
    Dim calendarNames() As String, selectedIndex As Variant
    Dim olItems As Object, ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim eintraege As Collection
    Dim datum As Date, startzeit As Date, endzeit As Date
    Dim produkt As String, hinweis As String, veranstaltungsnummer As String
    Dim titel As String, ort As String
    Dim alreadyProcessed() As Boolean

    ' Outlook vorbereiten
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        MsgBox "Outlook konnte nicht gestartet werden.", vbCritical
        Exit Sub
    End If
    Set olNS = olApp.GetNamespace("MAPI")
    Set allCalendars = New Collection

    ' Kalender sammeln
    Dim store As Object, folder As Object
    For Each store In olNS.Folders
        For Each folder In store.Folders
            If folder.DefaultItemType = 1 Then allCalendars.Add folder
        Next folder
    Next store

    ' Kalenderauswahl
    ReDim calendarNames(1 To allCalendars.Count)
    For i = 1 To allCalendars.Count
        calendarNames(i) = allCalendars(i).Parent.Name & " – " & allCalendars(i).Name
    Next i
    selectedIndex = Application.InputBox("Wähle den Zielkalender aus (Zahl):" & vbCrLf & Join(calendarNames, vbCrLf), "Kalenderauswahl", Type:=1)
    If Not IsNumeric(selectedIndex) Or selectedIndex < 1 Or selectedIndex > allCalendars.Count Then Exit Sub

    Set selectedCalendar = allCalendars(selectedIndex)
    Set olItems = selectedCalendar.Items
    olItems.IncludeRecurrences = True
    olItems.Sort "[Start]"

    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ReDim alreadyProcessed(1 To lastRow)

    ' Durch Einträge iterieren
    For i = 2 To lastRow
        If alreadyProcessed(i) Then GoTo Weiter

        ' Zeile validieren
        If Not IsDate(ws.Cells(i, "B").Value) Or ws.Cells(i, "G").Value = "" Then
            ws.Cells(i, "M").Value = "übersprungen (kein Datum/kein Produkt)"
            GoTo Weiter
        End If

        Set eintraege = New Collection
        veranstaltungsnummer = Trim(ws.Cells(i, "F").Value)
        produkt = Trim(ws.Cells(i, "G").Value)
        hinweis = Trim(ws.Cells(i, "L").Value)
        If InStr(hinweis, "Lehrgang: ") > 0 Then
            hinweis = Mid(hinweis, InStr(hinweis, "Lehrgang: ") + 10)
        End If
        titel = produkt & " - " & hinweis
        ort = ws.Cells(i, "J").Value

        ' Serie erkennen
        datum = ws.Cells(i, "B").Value
        eintraege.Add i
        alreadyProcessed(i) = True

        For j = i + 1 To lastRow
            If alreadyProcessed(j) Then GoTo SkipJ
            If Trim(ws.Cells(j, "F").Value) <> veranstaltungsnummer Then GoTo SkipJ
            If ws.Cells(j, "G").Value = "" Then GoTo SkipJ
            If Not IsDate(ws.Cells(j, "B").Value) Then GoTo SkipJ
            If ws.Cells(j, "B").Value - datum = 1 Or _
               (Weekday(datum, vbMonday) = 5 And ws.Cells(j, "B").Value - datum = 3) Then
                eintraege.Add j
                alreadyProcessed(j) = True
                datum = ws.Cells(j, "B").Value
            Else
                Exit For
            End If
SkipJ:
        Next j

        If eintraege.Count = 1 Then
            ' Einzeltermin
            Dim idx As Long: idx = eintraege(1)
            startzeit = ws.Cells(idx, "C").Value
            endzeit = ws.Cells(idx, "D").Value
            datum = ws.Cells(idx, "B").Value
            Call OutlookEintragErstellen(olItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer)
            ws.Cells(idx, "M").Value = titel
        Else
            ' Alte Einzeltermine löschen
            For Each idx In eintraege
                datum = ws.Cells(idx, "B").Value
                Call OutlookEintragLoeschen(olItems, datum, titel)
            Next idx

            ' Serientermin
            Dim appt As Object
            Set appt = selectedCalendar.Items.Add
            With appt
                .Start = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "C").Value
                .End = ws.Cells(eintraege(1), "B").Value + ws.Cells(eintraege(1), "D").Value
                .Subject = titel
                .Location = ort
                .Body = "Veranstaltungsnummer: " & veranstaltungsnummer
                .BusyStatus = 2
                .ReminderSet = False

                Dim pattern As Object
                Set pattern = .GetRecurrencePattern
                pattern.RecurrenceType = 0 ' daily
                pattern.Interval = 1
                pattern.PatternStartDate = ws.Cells(eintraege(1), "B").Value
                pattern.PatternEndDate = ws.Cells(eintraege(eintraege.Count), "B").Value
                pattern.NoEndDate = False

                .Save
            End With

            For Each idx In eintraege
                ws.Cells(idx, "M").Value = "Serie: " & titel
            Next idx
        End If
Weiter:
    Next i
    MsgBox "Einträge verarbeitet. Ergebnisse siehe Spalte M.", vbInformation
End Sub

Sub OutlookEintragErstellen(ByRef olItems As Object, datum As Date, startzeit As Date, endzeit As Date, titel As String, ort As String, nr As String)
    Dim item As Object, found As Boolean: found = False
    For Each item In olItems
        If item.Start = datum + TimeValue(startzeit) And item.Subject = titel Then
            found = True: Exit For
        End If
    Next item
    If Not found Then
        Dim appt As Object
        Set appt = olItems.Parent.Items.Add
        With appt
            .Start = datum + TimeValue(startzeit)
            .End = datum + TimeValue(endzeit)
            .Subject = titel
            .Location = ort
            .Body = "Veranstaltungsnummer: " & nr
            .ReminderSet = False
            .BusyStatus = 2
            .Save
        End With
    End If
End Sub

Sub OutlookEintragLoeschen(ByRef olItems As Object, datum As Date, titel As String)
    Dim item As Object
    For Each item In olItems
        If Int(item.Start) = Int(datum) And item.Subject = titel Then
            item.Delete
        End If
    Next item
End Sub