'-------------------------------------------------------------- 'SpecialDays.vbs '-------------------------------------------------------------- 'Created by: Ronald Booden 'Date: 12/23/2004 'Website: http://www.booden.net 'Tested with: Outlook 2000 and Outlook 2003 '-------------------------------------------------------------- 'Description: 'This script adds some special days to your Outlook calendar. 'Where possible recurrence is used, but for dates that depend 'on Easter, the next 10 years are added to the calendar. You 'can also use this script to delete the special days created 'with this script, first choosing 'No' and then 'Yes'. 'You can change special days as needed. Defaults are special 'days in Holland. '-------------------------------------------------------------- 'Easter calculation: 'Gregorian Calendar only (introduced in Oktober 1582/September 1752) 'Using John Horton Conway's method, see: 'http://quasar.as.utexas.edu/BillInfo/ReligiousCalendars.html 'http://www.faqs.org/faqs/astronomy/faq/part3/section-11.html '-------------------------------------------------------------- Option Explicit '-------------------------------------------------------------- 'Constants '-------------------------------------------------------------- Const olAppointmentItem = 1 Const olFolderCalendar = 9 Const olRecursYearly = 5 '-------------------------------------------------------------- 'Function: EasterDate '-------------------------------------------------------------- 'Return value: Date 'Attributes: intYear (integer) 'Description: Returns the Easter date for the given year. '-------------------------------------------------------------- Private Function EasterDate(ByVal intYear) Dim y, H, G, C, S, P Dim dtP, dtEaster y = intYear 'Calculate Paschal Full Moon G = (y Mod 19) + 1 H = (y - (y Mod 100)) / 100 C = -H + Fix(H / 4) + Fix(8 * (H + 11) / 25) S = (11 * G + C) Mod 30 While S < 0 S = S + 30 Wend P = 50 - S dtP = DateAdd("d", (P - 1), DateSerial(y, 3, 1)) If Month(dtP) = 4 And Day(dtP) = 19 Then dtP = DateAdd("d", -1, dtP) ElseIf Month(dtP) = 4 And Day(dtP) = 18 And G >= 12 Then dtP = DateAdd("d", -1, dtP) End If 'Determine easter If Weekday(dtP) = vbSunday Then dtEaster = DateAdd("ww", 1, dtP) Else dtEaster = dtP While Weekday(dtEaster) <> vbSunday dtEaster = DateAdd("d", 1, dtEaster) Wend End If EasterDate = dtEaster End Function '-------------------------------------------------------------- 'Function: AllDayItemExists '-------------------------------------------------------------- 'Return value: Boolean 'Attributes: dtDate (date) ' strSubject (string) 'Description: Returns true if the item on the given date with ' the given subject exists. If the global variable ' blnCleanup is true, then this function deletes ' the item if it is found and returns True. 'Requires: The global variables 'objNS' and 'blnCleanup' ' and the constant 'olFolderCalendar'. '-------------------------------------------------------------- Private Function AllDayItemExists(ByVal dtDate, ByVal strSubject) Dim objItems, strSearch, blnExists blnExists = blnCleanup strSearch = "[Start] = '" & FormatDateTime(dtDate, vbShortDate) & " 0:00' And [Subject] = '" & strSubject & "'" Set objItems = objNS.GetDefaultFolder(olFolderCalendar).Items objItems.Sort "[Start]" objItems.IncludeRecurrences = True Set objItems = objItems.Restrict(strSearch) If Not objItems Is Nothing Then If objItems.Count > 0 Then Dim item Set item = objItems.GetFirst() If Not item Is Nothing Then If blnCleanup Then If item.IsRecurring Then Call item.Parent.ClearRecurrencePattern Call item.Parent.Save Call item.Parent.Delete Else Call item.Delete End If End If blnExists = True End If Set item = Nothing End If End If Set objItems = Nothing AllDayItemExists = blnExists End Function '-------------------------------------------------------------- 'Subroutine: CreateAllDayItem '-------------------------------------------------------------- 'Attributes: dtDate (date) ' strSubject (string) 'Description: Creates an all day event on the given date with ' the given subject if this all day event does not ' exist. 'Requires: The global variable 'objOutlook' and the ' constant 'olAppointmentItem'. '-------------------------------------------------------------- Private Sub CreateAllDayItem(ByVal dtDate, ByVal strSubject) If Not AllDayItemExists(dtDate, strSubject) Then Dim objAppoint Set objAppoint = objOutlook.CreateItem(olAppointmentItem) objAppoint.Start = dtDate objAppoint.Subject = strSubject objAppoint.AllDayEvent = True objAppoint.ReminderSet = False objAppoint.Save Set objAppoint = Nothing End If End Sub '-------------------------------------------------------------- 'Subroutine: CreateRecurringAllDayItem '-------------------------------------------------------------- 'Attributes: dtDate (date) ' strSubject (string) 'Description: Creates an all day event on the given date with ' the given subject and sets a yearly recurrent ' pattern if this all day event does not exist. 'Requires: The global variable 'objOutlook' and the ' constants 'olAppointmentItem' and 'olRecursYearly'. '-------------------------------------------------------------- Private Sub CreateRecurringAllDayItem(ByVal dtDate, ByVal strSubject) If Not AllDayItemExists(dtDate, strSubject) Then Dim objAppoint Set objAppoint = objOutlook.CreateItem(olAppointmentItem) objAppoint.Start = dtDate objAppoint.Subject = strSubject objAppoint.AllDayEvent = True objAppoint.ReminderSet = False Dim objRP Set objRP = objAppoint.GetRecurrencePattern() objRP.RecurrenceType = olRecursYearly objRP.DayOfMonth = Day(dtDate) objRP.MonthOfYear = Month(dtDate) objRP.NoEndDate = True objAppoint.Save Set objRP = Nothing Set objAppoint = Nothing End If End Sub '-------------------------------------------------------------- 'Subroutine: SetAgendaForYear '-------------------------------------------------------------- 'Attributes: intYear (integer) 'Description: Sets the dates that depend on easter for the given ' year. '-------------------------------------------------------------- Private Sub SetAgendaForYear(ByVal intYear) Dim dtEaster dtEaster = EasterDate(intYear) Call CreateAllDayItem(DateAdd("d", -2, dtEaster), "Goede vrijdag") 'Good friday Call CreateAllDayItem(dtEaster, "1e Paasdag") 'Easter sunday Call CreateAllDayItem(DateAdd("d", 1, dtEaster), "2e Paasdag") 'Easter monday Call CreateAllDayItem(DateAdd("d", 39, dtEaster), "Hemelvaartsdag") 'Ascension Call CreateAllDayItem(DateAdd("d", 49, dtEaster), "1e Pinksterdag") 'Pentecost sunday Call CreateAllDayItem(DateAdd("d", 50, dtEaster), "2e Pinksterdag") 'Pentecost monday End Sub '-------------------------------------------------------------- 'Subroutine: SetRecurringAgendaFromYear '-------------------------------------------------------------- 'Attributes: intYear (integer) 'Description: Sets the dates that occur every year from the given ' year. '-------------------------------------------------------------- Private Sub SetRecurringAgendaFromYear(ByVal intYear) Call CreateRecurringAllDayItem(DateSerial(intYear, 1, 1), "Nieuwjaarsdag") 'New Years day Call CreateRecurringAllDayItem(DateSerial(intYear, 4, 30), "Koninginnedag") 'Queens day Call CreateRecurringAllDayItem(DateSerial(intYear, 5, 5), "Bevrijdingsdag") 'Liberation day Call CreateRecurringAllDayItem(DateSerial(intYear, 12, 5), "Sinterklaas") 'Saint Nicolas day Call CreateRecurringAllDayItem(DateSerial(intYear, 12, 25), "1e Kerstdag") 'Christmas day Call CreateRecurringAllDayItem(DateSerial(intYear, 12, 26), "2e Kerstdag") 'Boxing day Call CreateRecurringAllDayItem(DateSerial(intYear, 12, 31), "Oudjaarsdag") 'Old Years day End Sub '-------------------------------------------------------------- 'Executable code '-------------------------------------------------------------- Dim y, toY, objOutlook, blnCleanup, objNS 'Global variables y = Year(Date()) toY = y + 10 if MsgBox("Add special days from " & y & " to " & toY & " to your Outlook calendar?", vbYesNo) = vbYes then blnCleanup = False elseif MsgBox("Delete special days from your Outlook calendar?", vbYesNo) = vbYes then blnCleanup = True else WScript.Quit(1) end if Set objOutlook = CreateObject("Outlook.Application") Set objNS = objOutlook.GetNamespace("MAPI") Call SetRecurringAgendaFromYear(y) For y = y To toY Call SetAgendaForYear(y) Next Set objNS = Nothing Set objOutlook = nothing if blnCleanup then MsgBox "Finished the deletion of the special days from your Outlook calendar." else MsgBox "Finished the adding of the special days to your Outlook calendar." end if