Write an Internet Calendar File

We have a sacred duty in our department; probably in yours. Somebody has to bring donuts to staff meeting on Friday. I was determined to find a way to generate Calendar Files that I could send to the interested party each week. In the end, I created a monster (that I will share with you. The Internet Mail Consortium has more info on the specification.

This macro creates a number of small files

daDuty.htm is a list of the next four victims in a table that is used as a server-side include to bring into an information web. This is the #2 file opened.
The #1 file is the current ICS that can be read by Outlook or other desktop calendars.

There are examples of the resulting files and the Excel sheet that is read.

  
Option Explicit

Public DaMessage As String, StartDate As String, EndTime As String, DaGuy
Public daPath, LastRow, Zyx As Integer, QuOte As String, YelRow, GrnRow, haSh As String

Sub MakeVcalendar()
    Close #1, #2
    daPath = "C:\cybrNut\alan\excel\"	'Where you are going to put the files
    QuOte = Chr(34)			'Define " marks
    GrnRow = "<tr bgcolor=" & QuOte & "#CCFF99" & QuOte & ">"	'Define Green backgrd
    YelRow = "<tr bgcolor=" & QuOte & "#FFFFCC" & QuOte & ">"
    Sheets("TheDuty").Select			'Pickup sheet
    LastRow = Application.CountA(ActiveSheet.Range("A:A"))	'Get last row number
    Open daPath & "daDuty.htm" For Output As #2		'Open list table
    Print #2, "<table border=" & QuOte & "2" & QuOte & " width=" & QuOte _
        & "100%" & QuOte & ">"
    For Zyx = 2 To LastRow
        Select Case Cells(Zyx, 1)
            Case Is < Now()
                Application.StatusBar = "Skipped " & Zyx
            Case Is < Now() + 28	'If it is in the next 28 days
                Open daPath & Cells(Zyx, 2) & ".ics" For Output As #1

                Select Case Zyx		'Odd rows are green
                    Case 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31
                        Print #2, GrnRow
                        Print #2, "<TD>" & Application.Text(Cells(Zyx, 1), _
                            "mmmm dd") & "</TD>"
                        Print #2, "<TD>" & Cells(Zyx, 2) & "</TD>"
                        Print #2, "<TD><A HREF=" & QuOte & "sp/" & Cells(Zyx, 2) _
                            & ".ics" & QuOte & "><IMG SRC=" & QuOte & _
                            "sp/caldr.gif" & QuOte & " width=" & "33" & _
                            QuOte & " border=" & QuOte & "0" & QuOte & "></A></TR>"
                    Case Else
                        Print #2, YelRow
                        Print #2, "<TD>" & Application.Text(Cells(Zyx, 1), "mmmm dd") _
                            & "</TD>"
                        Print #2, "<TD>" & Cells(Zyx, 2) & "</TD>"
                        Print #2, "<TD><A HREF=" & QuOte & "sp/" & Cells(Zyx, 2) & _
                        ".ics" & QuOte & "><IMG SRC=" & QuOte & "sp/caldr.gif" _
                        & QuOte & " width=" & "33" & QuOte & " border=" _
                        & QuOte & "0" & QuOte & "></A></TR>"
                End Select
                haSh = Left(Hex(Hour(Now() + Zyx)), 2)
                If Len(haSh) < 2 Then
                    haSh = haSh & "A"
                End If
                StartDate = Cells(Zyx, 1) - 1
                Print #1, "BEGIN:VCALENDAR"
                Print #1, "PRODID:-//Microsoft Corporation//Outlook 9.0 MIMEDIR//EN"
                Print #1, "VERSION:2.0"
                Print #1, "METHOD:PUBLISH"
                Print #1, "BEGIN:VEVENT"
                Print #1, vbCrLf

                Print #1, "DTSTART:" & Application.Text(Cells(Zyx, 1), _
                    "YYYYMMDD") & "T110000Z"        '23=18:00
                Print #1, "DTSTAMP:" & Application.Text(Now(), "YYYYMMDD") _
                    & "T" & Application.Text(Now(), "HHMMSS") & "Z" '19970611T190000Z"
                Print #1, "DTEND:" & Application.Text(Cells(Zyx, 1), "YYYYMMDD") _
                    & "T123000Z"            '1230 = 7:30 AM CST

                Print #1, "LOCATION;ENCODING=QUOTED-PRINTABLE:1CC-9"
                Print #1, "TRANSP:OPAQUE"
                Print #1, "SEQUENCE:0"

                Print #1, "UID:alan.barasch@hymyonkel-stuff.com"
                Print #1, "DESCRIPTION;ENCODING=QUOTED-PRINTABLE:" _
                & "=0D=0AYou are assigned Donut Duty on " _
                & Cells(Zyx, 1) & "=0D=0AThis event has been added from a vCalendar" _
                & "format file. Advise Alan if you are unable to perform your duty" _
                & "this week so the schedule can be changed.=0D=0A" _
                & "=0APlease arrive early, if possible. Others are hungry!=0D=0A"
                Print #1, "SUMMARY;ENCODING=QUOTED-PRINTABLE:Donut Duty - " _
                    & Application.Text(Cells(Zyx, 1), "dddd, mm/dd/yyyy")
                Print #1, vbCrLf
                Print #1, "PRIORITY:5"
                Print #1, "CLASS:PUBLIC"
                Print #1, "BEGIN:VALARM"
                Print #1, "TRIGGER:PT1410M"
                Print #1, "ACTION:DISPLAY"
                Print #1, "DESCRIPTION:Reminder"
                Print #1, "END:VALARM"
                Print #1, "END:VEVENT"
                Print #1, "END:VCALENDAR"
                Close #1
            Case Else
        End Select
    Next
    Print #2, "</TABLE>"
    Close #2
    Open daPath & "opsdate.htm" For Output As #3
        Print #3, Application.Text(Now(), "dd mmmm yyyy HH:mm:ss")
    Close #3
    MakeHolidays	'Do the macro to produce holidays list (not doc yet)
    MsgBox "Done"
End Sub

Can't remember where I got it, but here is the Function for figuring Easter. To get Good Friday for my list since it is a company holiday, I use =EasterDate(2001)-2

Public Function EasterDate(Yr As Integer) As Date
    Dim d As Integer
    d = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
    EasterDate = DateSerial(Yr, 3, 1) + d + (d > 48) + 6 - ((Yr + Yr \ 4 + _
        d + (d > 48) + 1) Mod 7)
End Function

ARB

02/02/2002 20:53:57