Outlook Kalender ics per VBA Script automatisch per Email verschicken

On Error Resume Next
Dim objCal, objOL, objMail, objNS, objCalRec
Set objOL = GetObject(, "Outlook.Application")   
If Err.Number <> 0 then
  Set objOL = CreateObject("Outlook.Application")  
End if
Set objNS = objOL.GetNamespace("MAPI")  
Set objCalRec = objNS.CreateRecipient("Technik Bürki")  
objCalRec.Resolve
If objCalRec.Resolved then
  Set objCal = objNS.GetSharedDefaultFolder(objCalRec, 9).GetCalendarExporter
Else
  msgbox "Kontakt des Freigegebenen Kalenders wurde nicht gefunden!", vbExclamation  
  wscript.quit
End if

With objCal
    .CalendarDetail = 2    'FullDetails  
    .StartDate = Date
    .EndDate = Date
    Set objMail = .ForwardAsICal(1)    'Als Ereignisliste darstellen  
    objMail.To = "mail@domain.de;mail2@domain.de"  
    objMail.Subject = "Termine vom " & .StartDate  
    objMail.Send
    msgbox "Mail wurde gesendet!", vbInformation  
End With
Set objCal = Nothing
Set objMail = Nothing
Set objOL = Nothing
Set objNS = Nothing

Dim dic, dateStart, dateEnd, app, folderCalendar, prop, objOL, intNumDays, objMail, strEmail, objShell, fso
'definiert den Zeitraum in Tagen von Heute an, aus welchem Termine exportiert werden  
intNumDays = 90
'E-Mail-Adresse des Empfängers  
strEmail = "user@domain.de"  
'-------------------------------------------------  

On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")  
Set fso = CreateObject("Scripting.FilesystemObject")  
Set objOL = GetObject(, "Outlook.Application")  
If objOL Is Nothing Then
  Set objOL = CreateObject("Outlook.Application")  
End If
Set objShell = CreateObject("Wscript.Shell")  
strTempDir = objShell.ExpandEnvironmentStrings("%temp%")  


'Startdatum für den Terminexport  
dateStart = Date
'Enddatum für den Terminexport  
dateEnd = DateAdd("d", intNumDays, dateStart)  

Set folderCalendar = objOL.GetNamespace("MAPI").GetDefaultFolder(9)  
'Termine auf den angegebenen Zeitraum beschränken und Serientermine ausschließen (sind im iCal-Format nicht möglich)  
For Each app In folderCalendar.items.Restrict("[Start] >= '" & FormatDateTime(dateStart,2) & " " & FormatDateTime(dateStart,4) & "' AND [Start] <= '" & FormatDateTime(dateEnd,2) & " " & FormatDateTime(dateEnd,4) & "' AND [IsRecurring] = False")  
    'benutzerdefinierte Eigenschaft suchen  
    Set prop = app.UserProperties.Find("googlecalexport")  
    If Not prop Is Nothing Then
    	'wenn sie gefunden wurde vergleiche das Datum der Eigenschaft mit dem Datum der letzten Modifikation  
    	'wurde Termin seit dem letzen Export geändert, exportiere ihn erneut  
        If prop.Value < app.LastModificationTime Then
            dic.Add app,""  
            app.UserProperties("googlecalexport").Value = DateAdd("s", 10, Now())  
            app.Save
        End If
    Else	' benutzerdefinierte Eigenschaft wurde nicht gefunden, Termin ist also neu  
        dic.Add app,""  
        Set prop = app.UserProperties.add("googlecalexport", 5)  
        prop.Value = DateAdd("s", 10, Now())  
        app.Save
    End If
Next
If dic.Count > 0 Then	'wenn Termine für den Export vorhanden sind erstelle eine neue Mail mit dem ICS-Kalender als Attachment  
    ExportAppointmentCollectionAsICal dic, strTempDir & "\termine.ics"  
    Set objMail = objOL.CreateItem(0)
    objMail.Subject = "Termine von " & dateStart & " bis " & dateEnd  
    objMail.To = strEmail
    objMail.Body = "Anbei finden sie die Termine im iCal-Format"  
    objMail.Attachments.Add strTempDir & "\termine.ics"  
    'objMail.Display  
    Mail senden
    objMail.Send
    objShell.Popup "Es wurden " & dic.Count & " Termin(e) als Kalender verschickt",2,"Termin-Mailer",64  
Else	'keine neuen Termine vorhanden  
	objShell.Popup "Keine aktuellen Termine zu verschicken",1,"Termin-Mailer",48  
End If

Set fso = Nothing
Set objShell = Nothing
Set objOL = Nothing
Set dic = Nothing

Sub ExportAppointmentCollectionAsICal(colApp,strOutPath)
    Dim strDateNow, app, strOut
    
    'Regex um das Event aus dem File zu extrahieren  
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    regex.MultiLine = True
    regex.pattern = "^BEGIN:VEVENT[\s\S]*^END:VEVENT"  
    
    'Ausgabedatei löschen falls sie exisitiert  
    If fso.FileExists(strOutPath) Then fso.DeleteFile strOutPath,True
    
    'ics header schreiben  
    strOut = "BEGIN:VCALENDAR" & vbNewLine & _  
    	     "PRODID:-//Microsoft Corporation//Outlook 14.0 MIMEDIR//EN" & vbNewLine & _  
    	     "VERSION:2.0" & vbNewLine & _  
        	 "METHOD:PUBLISH" & vbNewLine & _  
        	 "BEGIN:VTIMEZONE" & vbNewLine & _  
        	 "TZID:W. Europe Standard Time" & vbNewline & _  
        	 "BEGIN:STANDARD" & vbNewline & _  
        	 "DTSTART:16011028T030000" & vbNewline & _  
        	 "RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10" & vbNewline & _  
        	 "TZOFFSETFROM:+0200" & vbNewline & _  
        	 "TZOFFSETTO:+0100" & vbNewline & _  
        	 "END:STANDARD" & vbNewline & _  
        	 "BEGIN:DAYLIGHT" & vbNewline & _  
       		 "DTSTART:16010325T020000" & vbNewline & _  
         	 "RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=3" & vbNewline & _  
        	 "TZOFFSETFROM:+0100" & vbNewline & _  
        	 "TZOFFSETTO:+0200" & vbNewline & _  
        	 "END:DAYLIGHT" & vbNewline & _  
        	 "END:VTIMEZONE" & vbNewLine  
    
    ' exportiere jedes Event in ein temporäres ics und extrahiere dieses aus dem File  
    keys = colApp.Keys()
    For i = 0 To colApp.Count -1
        Dim objTempMail, strEventContents, matches, strEvent
        Set objTempMail = keys(i).ForwardAsVcal()
        strFileEvent = strTempDir & "\event.vcs"  
        If fso.FileExists(strFileEvent) Then fso.DeleteFile strFileEvent, True
        objTempMail.Attachments.Item(1).SaveAsFile strFileEvent
        strEventContents = fso.OpenTextFile(strFileEvent, 1).ReadAll()
        Set matches = regex.Execute(strEventContents)
        If Not matches Is Nothing Then
            strEvent = matches(0)
        End If
        strOut = strOut & strEvent & vbNewLine
    
        fso.DeleteFile strFileEvent, True
        Set objTempMail = Nothing
    Next
    strOut = strOut & "END:VCALENDAR" & vbNewLine  
    
    With CreateObject("ADODB.Stream")  
		.Type = 2 : .Charset = "UTF-8" : .Open  
	  	.WriteText strOut
	  	.SaveToFile strOutPath, 2
	  	.Close
	End With
  
    Set regex = Nothing
End Sub

"[SENSITIVITY] = 0"

For Each app In folderCalendar.items.Restrict("[Start] >= '" & FormatDateTime(dateStart,2) & " " & FormatDateTime(dateStart,4) & "' AND [Start] <= '" & FormatDateTime(dateEnd,2) & " " & FormatDateTime(dateEnd,4) & "' AND [IsRecurring] = False AND [SENSITIVITY] = 0") 

.StartDate = 24.08.2018
.EndDate = 31.08.2018 + 6

.StartDate = CDate("24.08.2018")  
.EndDate = DateAdd("d",6, CDate("31.08.2018"))  

Sub ErinnerungKalender()
On Error Resume Next
Dim objCal, objOL, objMail
Set objOL = GetObject(, "Outlook.Application")  
If Err.Number <> 0 Then
  Set objOL = CreateObject("Outlook.Application")  
End If
Set objCal = objOL.GetNamespace("MAPI").GetDefaultFolder(9).GetCalendarExporter    'Standardkalender Exporter holen  
With objCal
    .CalendarDetail = 2    'FullDetails  
    .StartDate = CDate("24.08.2018")  
    .EndDate = DateAdd("d", 0, CDate("31.08.2018"))  
    Set objMail = .ForwardAsICal(1)    'Als Ereignisliste darstellen  
    objMail.To = "anil.suer@gmx.de"  
    objMail.Subject = "Termine vom " & .StartDate & " bis " & .EndDate  
    objMail.Send
End With
Set objCal = Nothing
Set objMail = Nothing
Set objOL = Nothing
End Sub

.StartDate = Date
.EndDate = Date + 6

.EndDate = DateAdd("d", 6, Date)