Pendler-Kalender (Outlook Makro)

Public Sub Pendlerkalender()
    ' Hinweise:
    ' - Es wird ein Verweis auf "Microsoft Scripting Runtime" benötigt (Extras -> Verweise)

    Set termine = Application.Session.GetDefaultFolder(olFolderCalendar).Folders("Pendlerkalender").Items
    Set tageThisYear = New Dictionary
    Set csvTextPerYear = New Dictionary
    lastYear = 1000

    termine.Sort "[Start]"
    For Each termin In termine
        If lastYear < Year(termin.Start) Then
            lastYear = Year(termin.Start)
            tageThisYear.RemoveAll
            csvTextPerYear.Add Year(termin.Start), ""
        End If

        If Not tageThisYear.Exists(termin.Subject) Then
            tageThisYear.Add termin.Subject, 0
        End If

        currentAnzahlThisYear = tageThisYear.Item(termin.Subject) + 1
        tageThisYear.Item(termin.Subject) = currentAnzahlThisYear

        termin.Location = "[Berechnet] Stand: Dieses Jahr " + CStr(currentAnzahlThisYear) + " Tage"
        termin.Body = "Zuletzt berechnet: " + CStr(Now)
        termin.Save

        csvLine = Format(termin.Start, "dd.mm.yyyy") + ";" + termin.Subject + vbCrLf
        csvTextPerYear.Item(Year(termin.Start)) = csvTextPerYear.Item(Year(termin.Start)) + csvLine
    Next

    csvExportPath = "B:\Dokumente\Arbeit\Pendlerkalender\"
    Set fso = New FileSystemObject
    csvHeader = "Datum;Kategorie" + vbCrLf
    For Each dictKey In csvTextPerYear.Keys
        Set stream = fso.CreateTextFile(csvExportPath + CStr(dictKey) + ".csv", True)
        stream.Write csvHeader + csvTextPerYear.Item(dictKey)
        stream.Close
    Next
End Sub