Ich war auf der Suche nach einer Lösung, um Dateien vom Typ iCalendar zu erzeugen.
Hintergrund war, dass in einem Verein Terminlisten verschickt wurden, die dann jeder vielleicht händisch in seinen Kalender übertragen hat.
Ich dachte, dass es sinnvoll sein könnte, das gleich als Kalenderdatei zu verschicken, damit die Leute das, sofern sie das denn wollen in ihren Kalender einfach importieren können.
Ich bin nun bei meiner Suche nach Lösungen auf einen Beitrag im Archiv gestoßen:
https://www.herber.de/forum/archiv/1224to1228/1225493_iCal_Datei_aus_Excel_erstellen_Kalender_ics.html
was schon etwas hilft, aber doch diverse Schwächen hat.
Primär sollte die Datei UTF-8 sein, was sie nicht ist.
Dann ist es offenbar so, dass da pro Termin eine UID aus dem aktuellem Datum und der Zeit generiert wird, was insofern ungünstig ist,
als man eine Änderung an einem Termin nur mit einer bekannten UID vornehmen kann.
Ich habe also ein Tabellenblatt angelegt, das in der 2ten Zeile nacheinander folgende Titel ausweist:
UID, Datum, Beginn, Ende, Titel, Ort, Beschreibung
In Zeile 1, Spalte 2 hab ich den Dateinamen mit Pfad und dazu folgendes in VBA:
Option Explicit
Sub ICS_Erstellen()
'Erstellt den Zeitstempel für den aktuellen Zeitpunkt
Dim strTimeStamp As String
strTimeStamp = getTimeStamp(Now, Now)
'Erstellt den Inhalt der Kalenderdatei
Dim sText As String
sText = ""
'Schreibt den allgemeinen Teil der Kalenderdatei in Variable sText
sText = sText & "BEGIN:VCALENDAR" & vbCrLf
sText = sText & "VERSION:2.0" & vbCrLf
sText = sText & "PRODID:MV_Schwebheim" & vbCrLf
sText = sText & "METHOD:PUBLISH" & vbCrLf
Dim iLine As Integer
Dim strStartStamp As String
Dim strEndStamp As String
Dim strTitle As String
Dim strPlace As String
Dim strDesc As String
Dim strID As String
'Schleife zur Ermittlung aller Einträge
'Benutzt alle Datensätze, die ein Datum enthalten
iLine = 3
While ThisWorkbook.Sheets(1).Cells(iLine, 2).Value > ""
strID = ThisWorkbook.Sheets(1).Cells(iLine, 1).Value
strStartStamp = getTimeStamp(ThisWorkbook.Sheets(1).Cells(iLine, 2).Value, ThisWorkbook.Sheets(1).Cells(iLine, 3).Value)
strEndStamp = getTimeStamp(ThisWorkbook.Sheets(1).Cells(iLine, 2).Value, ThisWorkbook.Sheets(1).Cells(iLine, 4).Value)
strTitle = ThisWorkbook.Sheets(1).Cells(iLine, 5).Value
strPlace = ThisWorkbook.Sheets(1).Cells(iLine, 6).Value
strDesc = ThisWorkbook.Sheets(1).Cells(iLine, 7).Value
'Ergänzt einen Kalendereintrag
sText = sText & "BEGIN:VEVENT" & vbCrLf
sText = sText & "UID:" & strID & vbCrLf
sText = sText & "CLASS:PUBLIC" & vbCrLf
sText = sText & "SUMMARY:" & strTitle & vbCrLf
sText = sText & "DESCRIPTION:" & strDesc & vbCrLf
sText = sText & "LOCATION:" & strPlace & vbCrLf
sText = sText & "DTSTART;TZID=Europe/Berlin:" & strStartStamp & vbCrLf
sText = sText & "DTEND;TZID=Europe/Berlin:" & strEndStamp & vbCrLf
sText = sText & "DTSTAMP:" & strTimeStamp & vbCrLf
sText = sText & "LAST-MODIFIED:" & strTimeStamp & vbCrLf
sText = sText & "BEGIN:VALARM" & vbCrLf
sText = sText & "TRIGGER;VALUE=DURATION:-PT30M" & vbCrLf
sText = sText & "REPEAT:2" & vbCrLf
sText = sText & "DURATION:PT5M" & vbCrLf
sText = sText & "ACTION:DISPLAY" & vbCrLf
sText = sText & "DESCRIPTION: Termin " & strTitle & vbCrLf
sText = sText & "END:VALARM" & vbCrLf
sText = sText & "END:VEVENT" & vbCrLf
iLine = iLine + 1
Wend
'Ende der Schleife
sText = sText & "END:VCALENDAR"
'Ende der Kalenderdatei
'sText nach UTF streamen
Dim adodbStreamUTF
Dim adodbStreamBIN
Set adodbStreamUTF = CreateObject("ADODB.Stream")
Set adodbStreamBIN = CreateObject("ADODB.Stream")
With adodbStreamUTF
.Type = 2 'Text Type
.Charset = "UTF-8"
.Open
.WriteText sText 'Text schreiben
.flush
End With
'UTF Stream als Binary schreiben (ohne Byte Order Mark)
With adodbStreamBIN
.Type = 1 'Binary Type
.Open
adodbStreamUTF.Position = 3 'nach BOM
adodbStreamUTF.copyto adodbStreamBIN
.SaveToFile ThisWorkbook.Sheets(1).Cells(1, 2).Value, 2 'Datei speichern, ggf. neu erzeugen
.Close
End With
adodbStreamUTF.Close
MsgBox "Datei geschrieben"
End Sub
Function getTimeStamp(Datum As Date, Zeit As Date) As String
Dim strTimeStamp
strTimeStamp = Right("0000" & Year(Datum), 4)
strTimeStamp = strTimeStamp & Right("00" & Month(Datum), 2)
strTimeStamp = strTimeStamp & Right("00" & Day(Datum), 2)
strTimeStamp = strTimeStamp & "T"
strTimeStamp = strTimeStamp & Right("00" & Hour(Zeit), 2)
strTimeStamp = strTimeStamp & Right("00" & Minute(Zeit), 2)
strTimeStamp = strTimeStamp & Right("00" & Second(Zeit), 2)
strTimeStamp = strTimeStamp & "Z"
getTimeStamp = strTimeStamp
End Function
Das erfüllt jetzt schon mal grob den Zweck.
Vielleicht hat aber jemand auch noch eine Idee, wie man den Terminen eine Kategorie oder Farbe zuordnen kann?
Ich habe hier eingebaut, dass grundsätzlich eine halbe Stunde vor Termin noch ne Meldung kommt , die dann noch 2 mal jeweils nach 5 Minuten wiederholt wird.
Das denke ich jedenfalls.
Vielleicht hat da jemand auch da noch eine Idee, wie man das etwas flexibler lösen kann.
Ein Hinweis auf eine ausführliche Beschreibung zu .iCalendar Dateien würde mich evtl. auch schon weiter bringen.
Danke