iCal bzw. ics Datei erstellen.

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