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

Sub SerienKalendereintraegeErstellen()
    ' Benutzer wird gefragt, ob Simulation gewünscht ist
    Dim userResponse As VbMsgBoxResult
    userResponse = MsgBox("Möchtest du eine Simulation durchführen (keine Einträge werden erstellt oder gelöscht)?", vbYesNo + vbQuestion, "Simulationsmodus")
    Dim DRYRUN As Boolean
    DRYRUN = (userResponse = vbYes) ' True = Simulation, False = Echtbetrieb

    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, erstelltCount As Long, serienCount As Long, geloeschtCount As Long, uebersprungenCount 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
    Dim startTime As Double
    Dim logSheet As Worksheet

    startTime = Timer

    If Not DRYRUN Then
        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

        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

        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)
        MsgBox "Ausgewählter Kalender: " & selectedCalendar.Name, vbInformation, "Kalenderbestätigung"
        Set olItems = selectedCalendar.Items
        olItems.Sort "[Start]"
        olItems.IncludeRecurrences = True

        Dim gefilterteItems As Object
        Dim filterDatum As String
        filterDatum = Format(Date, "mm/dd/yyyy 12:00 AM")
        Set gefilterteItems = olItems.Restrict("[Start] >= '" & filterDatum & "'")
        Debug.Print "Gefilterte Einträge: " & gefilterteItems.Count

        On Error Resume Next
        Set logSheet = ThisWorkbook.Sheets("Gelöschte Termine")
        If logSheet Is Nothing Then
            Set logSheet = ThisWorkbook.Sheets.Add
            logSheet.Name = "Gelöschte Termine"
            logSheet.Range("A1:D1").Value = Array("Datum", "Startzeit", "Titel", "Kalender")
        End If
        On Error GoTo 0
    End If

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

    For i = 2 To lastRow
        If alreadyProcessed(i) Then GoTo Weiter

        If ws.Cells(i, "B").Value < DateSerial(Year(Date), Month(Date), Day(Date)) Then
            ws.Cells(i, "M").Value = "übersprungen (Vergangenheit)"
            uebersprungenCount = uebersprungenCount + 1
            GoTo Weiter
        End If

        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)"
            uebersprungenCount = uebersprungenCount + 1
            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
        If Trim(titel) = "-" Or Trim(titel) = "- -" Or Trim(titel) = "" Then
            ws.Cells(i, "M").Value = "übersprungen (leerer Titel)"
            uebersprungenCount = uebersprungenCount + 1
            GoTo Weiter
        End If
        ort = ws.Cells(i, "J").Value

        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
            Dim idx As Variant: idx = eintraege(1)
            If IsDate(ws.Cells(idx, "C").Value) Then
                startzeit = TimeValue(ws.Cells(idx, "C").Value)
            Else
                ws.Cells(idx, "M").Value = "übersprungen (ungültige Startzeit)"
                GoTo Weiter
            End If

            If IsDate(ws.Cells(idx, "D").Value) Then
                endzeit = TimeValue(ws.Cells(idx, "D").Value)
            Else
                ws.Cells(idx, "M").Value = "übersprungen (ungültige Endzeit)"
                GoTo Weiter
            End If
            datum = DateValue(ws.Cells(idx, "B").Value)
            If DRYRUN Then
                ws.Cells(idx, "M").Value = "[Simulation] Einzel: " & titel
            Else
                Call OutlookEintragErstellen(selectedCalendar, gefilteteItems, datum, startzeit, endzeit, titel, ort, veranstaltungsnummer)
                ws.Cells(idx, "M").Value = titel
            End If
            ws.Cells(idx, "N").Value = IIf(DRYRUN, "(Simulation)", selectedCalendar.Name)
            erstelltCount = erstelltCount + 1
            With ws.Cells(idx, "M").Interior: .Color = RGB(198, 239, 206): End With
        Else
            For Each idx In eintraege
                datum = ws.Cells(idx, "B").Value
                If Not DRYRUN Then
                    Call OutlookEintragLoeschen(gefilteteItems, datum, titel, logSheet, selectedCalendar.Name)
                    geloeschtCount = geloeschtCount + 1
                End If
            Next idx
            If DRYRUN Then
                For Each idx In eintraege
                    ws.Cells(idx, "M").Value = "[Simulation] Serie: " & titel
                    ws.Cells(idx, "N").Value = "(Simulation)"
                    serienCount = serienCount + 1
                    With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With
                Next idx
            Else
                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
                    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
                    ws.Cells(idx, "N").Value = selectedCalendar.Name
                    serienCount = serienCount + 1
                    With ws.Cells(idx, "M").Interior: .Color = RGB(255, 235, 156): End With
                Next idx
            End If
        End If
Weiter:
    Next i

    MsgBox "Fertig in " & Format(Timer - startTime, "0.00") & " Sekunden." & vbCrLf & _
           erstelltCount & " Einzeltermine erstellt" & vbCrLf & _
           serienCount & " Serien-Einträge erstellt" & vbCrLf & _
           geloeschtCount & " alte Termine gelöscht" & vbCrLf & _
           uebersprungenCount & " Zeilen übersprungen", vbInformation
End Sub


' Hilfsfunktion zum Erstellen eines Einzeltermins
Sub OutlookEintragErstellen(ByVal selectedCalendar As Object, ByVal gefilteteItems As Object, ByVal datum As Date, ByVal startzeit As Date, ByVal endzeit As Date, ByVal titel As String, ByVal ort As String, ByVal veranstaltungsnummer As String)
    Dim item As Object, existingItem As Object
    Dim itemDate As Date
    Dim bodyText As String

    For Each existingItem In gefilteteItems
        If existingItem.Class = 26 Then ' nur AppointmentItems
            itemDate = Int(existingItem.Start)
            If itemDate = datum Then
                bodyText = "" & existingItem.Body
                If InStr(bodyText, veranstaltungsnummer) > 0 Then
                    If existingItem.Subject <> titel Then
                        Dim msg As VbMsgBoxResult
                        msg = MsgBox("Ein Kalendereintrag mit derselben Veranstaltungsnummer existiert, aber der Titel unterscheidet sich:" & vbCrLf & _
                                         "Bestehender Titel: " & existingItem.Subject & vbCrLf & _
                                         "Neuer Titel: " & titel & vbCrLf & vbCrLf & _
                                         "Trotzdem neuen Eintrag erstellen?", vbYesNo + vbExclamation, "Unstimmigkeit bei Titel")
                        If msg = vbNo Then Exit Sub
                    Else
                        Debug.Print "Duplikat gefunden für Datum: " & datum & ", Titel: " & titel
                        Exit Sub ' Duplikat mit gleichem Titel und Veranstaltungsnummer
                    End If
                End If
                Debug.Print "Übersprungen wegen vorhandenem Eintrag: " & datum & " - " & titel
                Exit Sub
            End If
        End If
    Next

    Set item = selectedCalendar.Items.Add
    With item
        .Start = datum + startzeit
        .End = datum + endzeit
        .Subject = titel
        .Location = ort
        .Body = "Veranstaltungsnummer: " & veranstaltungsnummer
        .BusyStatus = 2
        .ReminderSet = False
        .Save
    End With
End Sub


' Hilfsfunktion zum Löschen vorhandener Einzeltermine mit gleichem Titel am gegebenen Datum
Sub OutlookEintragLoeschen(ByVal gefilteteItems As Object, ByVal datum As Date, ByVal titel As String, ByVal logSheet As Worksheet, ByVal kalenderName As String)
    Dim item As Object
    Dim itemDate As Date
    For Each item In gefilteteItems
        If item.Class = 26 Then ' nur AppointmentItems
            itemDate = Int(item.Start)
            If itemDate = datum And item.Subject = titel Then
                logSheet.Cells(logSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(1, 4).Value = _
                    Array(Format(item.Start, "dd.mm.yyyy"), Format(item.Start, "hh:nn"), titel, kalenderName)
                item.Delete
                Exit For
            End If
        End If
    Next
End Sub