问题
The task was to send a bunch of emails with appointments from an Excel on a regular bases. For that purpose, I included macros that generated iCalendar files, attached them to an email and send them automatically.
Problem:
The email part was the easiest one. But not the iCalendar entry! If you simply generate an entry with start and end time, it is importable by Outlook and shows the correct times in your calendar. But if you try to import this entry in your Android phone or iPhone, you get wrong times or even error messages.
The biggest problem is the fact, that Android treated everything as UTC coded. Ok, then create the iCalendar entry in UTC and the problem is solved. But that sounds easier than done. Especially when you live in Europe and have to deal with daylight saving and sending of emails with iCalendar entries that are stepping over the saving start or end date.
Solution:
To calculate correct conversion from the local time to UTC, one can use two function calls into the Kernel32 module of Windows to do all the math:
GetTimeZoneInformation and TzSpecificLocalTimeToSystemTime
To check whether your iCalendar entry is correct, there are website that offer online validation. I used this one: https://icalendar.org/validator.html. If this validator doesn't complain anymore, you're good. The iCalendar entry generated from the code below is now accepted from all applications and produces the correct times everywhere.
Start the routine TestIt to see how it works.
The current code only generates an email, the user has to press the send button manually. But if you move the comment tic from '.Send to .Display, the email will be send without further notice. You will find it in your send folder.
Screenshot from the composed email
Here is the code:
Option Explicit
' For time & date conversion from CET/CEST to UTC see
' https://docs.microsoft.com/en-us/windows/desktop/api/timezoneapi/nf-timezoneapi-gettimezoneinformation
' and
' https://docs.microsoft.com/en-us/windows/desktop/api/timezoneapi/nf-timezoneapi-tzspecificlocaltimetosystemtime
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To 31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To 31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Private Declare Function GetTimeZoneInformation Lib "Kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function TzSpecificLocalTimeToSystemTime Lib "Kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION, _
lpLocalTime As SYSTEMTIME, lpUniversalTime As SYSTEMTIME) As Integer
Public objFSO As New FileSystemObject
Private Sub TestIt()
Call SendTextEmailWith_iCalendar("joe.sixpack@example.com", "2019-02-28 14:00", "2019-02-28 14:30")
End Sub
' This subroutine creates / sends a plain text formatted email with an iCalendar entry as attachment.
Private Sub SendTextEmailWith_iCalendar( _
EmailAddress As String, _
EventStart As Date, _
EventEnd As Date _
)
Dim objOutlook As Object
Dim objMail As Object
Dim TempIcsFilename As String
' Put date, start and end time into filename.
TempIcsFilename = Environ$("temp") & "\iCalendar Entry " & Format(EventStart, "YYYYMMDD") & " " & _
Format(EventStart, "hhmm") & "-" & Format(EventEnd, "hhmm") & ".ics"
Call Create_iCalendar_File(TempIcsFilename, EventStart, EventEnd, "This is the summary", _
"This is the location", 5)
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = EmailAddress
.Subject = "Your appointment at " & Format(EventStart, "YYYY-MM-DD"" at ""hh:mm"" hours""")
.Body = "This is an automated email with an iCalendar entry for your next appointment."
.Attachments.Add TempIcsFilename
.Display ' Displays only the composed email. The user has to send it.
'.Send ' Sends the composed email without further query.
End With
Kill TempIcsFilename
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
' Creates an iCalendar file of the given arguments with UTC coded start-date and end-date.
' This will then be accepted by Android and iOS calendar apps as well as MS Outlook with the correct
' time local time.
Private Sub Create_iCalendar_File( _
Filename As String, _
EventStart As Date, _
EventEnd As Date, _
Summary As String, _
Optional Location As String = "", _
Optional Reminder As Integer = 15 _
)
Dim fso As Object
Dim TimeZoneInfo As TIME_ZONE_INFORMATION
Dim UTC As SYSTEMTIME
Dim LocalTime As SYSTEMTIME
' Get the time zone info of the system settings.
Call GetTimeZoneInformation(TimeZoneInfo)
' Create an iCalendar file for the specified time window. Some of the properties seem superfluous
' or redundant at first glance. Ommitting them leads to warnings / errors in some calendar tools.
' Use iCalendar Validator from https://icalendar.org/validator.html to check your entry.
Set fso = objFSO.CreateTextFile(Filename, Overwrite:=True)
With fso
.WriteLine ("BEGIN:VCALENDAR")
.WriteLine ("PRODID:-//<Replace this with your program/company info>//EN")
.WriteLine ("VERSION:2.0")
.WriteLine ("BEGIN:VEVENT")
.WriteLine ("UID:<Make this unique for your program>-" & Format(Now(), "YYYYMMDD""-""hhmmss"))
' Timezone doesn't matter for the time stamp.
.WriteLine ("DTSTAMP:" & Format(Now(), "YYYYMMDD""T""hhmmss"))
LocalTime = DateToSystemTime(EventStart)
Call TzSpecificLocalTimeToSystemTime(TimeZoneInfo, LocalTime, UTC)
.WriteLine ("DTSTART:" & SystemTimeToDTString(UTC))
LocalTime = DateToSystemTime(EventEnd)
Call TzSpecificLocalTimeToSystemTime(TimeZoneInfo, LocalTime, UTC)
.WriteLine ("DTEND:" & SystemTimeToDTString(UTC))
.WriteLine ("LOCATION:" & Location)
.WriteLine ("PRIORITY:5") ' Normal priority
.WriteLine ("SEQUENCE:0")
.WriteLine ("SUMMARY:" & Summary)
.WriteLine ("BEGIN:VALARM")
.WriteLine ("TRIGGER:-PT" & Reminder & "M")
.WriteLine ("ACTION:DISPLAY")
.WriteLine ("DESCRIPTION:Reminder")
.WriteLine ("END:VALARM")
.WriteLine ("END:VEVENT")
.WriteLine ("END:VCALENDAR")
.Close
End With
Set fso = Nothing
End Sub
' Convert Date into SYSTEMTIME
Private Function DateToSystemTime(TimeStamp As Date) As SYSTEMTIME
With DateToSystemTime
.wYear = Year(TimeStamp)
.wMonth = Month(TimeStamp)
.wDay = Day(TimeStamp)
.wHour = Hour(TimeStamp)
.wMinute = Minute(TimeStamp)
.wSecond = Second(TimeStamp)
.wMilliseconds = 0
End With
End Function
' Convert SYSTEMTIME into a DTSTART/DTEND string
Private Function SystemTimeToDTString(TimeStamp As SYSTEMTIME) As String
With TimeStamp
SystemTimeToDTString = Format(DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond), _
"YYYYMMDD""T""hhmmss""Z""")
End With
End Function
来源：https://stackoverflow.com/questions/54876217/how-to-generate-an-icalendar-entry-that-works-on-outlook-android-and-ios