DisplayYearlyCalendar() Sub DisplayYearlyCalendar() 'copyright Nick Roemer 'http://niveauverleih.blogspot.com/ 'version 2.1, 22 Jan 2009 'this script (formerly: macro) will display the Outlook appointments over a period of several months 'or an empty calendar to print out 'the output is are 2 html files (1 portrait, 1 landscape) that are displayed with Internet Explorer 'Safe this file as "Yearly calendar v2.vbs" and doubleclick the resulting file to run the script '----------------------------------------------------------------------------------------------- 'some necessary objects and constants Const ForWriting = 2 Set objShell = CreateObject("WScript.Shell") strTempFolder = objShell.ExpandEnvironmentStrings("%TEMP%") & "\YearCalendar" Set objFSO = CreateObject("Scripting.FileSystemObject") If NOT objFSO.FolderExists(strTempFolder) Then objFSO.CreateFolder strTempFolder End If Set OL = createObject("Outlook.Application") Set onNamespace = OL.GetNamespace("MAPI") 'SELECT THE MAILBOX / CALENDAR TO BE DISPLAYED 'Choose between options A, B and C 'uncomment the chosen code paragraph '--- A --- you specifiy the name of the mailbox that contains the calendar you need 'strMailbox = "MBX -- ServiceDesk" 'results = split (GetExchangeServer(strMailbox),"|") 'strServer = "" 'on error resume next 'strServer = results(1) 'strFolderName = results(0) 'on error goto 0 'Set MyCalendar = onNamespace.Folders(strFolderName).Folders("Calendar") 'if you want to indicate a calendar in a different mailbox 'OR --- B --- You pick a CALENDAR (If you have several) 'Set MyCalendar = onNamespace.PickFolder 'if you want to select your calendar folder manually (if you have several) 'strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","") 'results = split (GetExchangeServer(strMailbox),"|") 'strServer = "" 'on error resume next 'strServer = results(1) 'on error goto 0 'OR --- C --- You simply use the default calendar Set MyCalendar = onNamespace.GetDefaultFolder(9) ' if you want to use the default calendar strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","") results = split (GetExchangeServer(strMailbox),"|") strServer = "" on error resume next strServer = results(1) on error goto 0 'FILTER CATEGORIES 'list here the categories that you want to hide arrExcludeCategories = Array() 'arrExcludeCategories = Array("Personal", "StaffMeetings") 'HIDE PRIVATE APPOINTMENTS 'Set this to TRUE if you want to display private appointments Const blShowPrivateAppointments = TRUE 'ALIGN BY WEEKDAY / DAY-OF-MONTH 'Set this to FALSE if you want the rows to be the day of month (1,2, ...31) iso. the days of the week (Mo .. Fri) Const blAlignWeekDays = True 'ONLY ALL-DAY-EVENTS 'Set this to TRUE if you want to display AllDayEvents only blAllDayEventsOnly = False 'COLORS used 'colors from http://web.njit.edu/~kevin/rgb.txt.html Const wheat_light = "#EED8AE" Const wheat_dark = "#CDBA96" Const seashell = "#EEE5DE" Const silver = "#C0C0C0" Const cornsilk = "#FFF8DC" 'NAME AND LOCATION OF HTML OUTPUT FILES strHtmlFile = strTempFolder & "\YearlyCalendar.html" strHtmlFileTransposed = strTempFolder & "\YearlyCalendarTransposed.html" strHtmlFile7Columns = strTempFolder & "\YearlyCalendar7Columns.html" 'SCRIPT BEGIN 'ASKING FOR TIMESPAN TO BE DISPLAYED 'ENTER 13 for next January etc. StartMonth = InputBox("Start Month", "Start Month", Month(Date)) If StartMonth = "" Then Exit Sub StartMonth = CInt(StartMonth) EndMonth = InputBox("End Month", "End Month", StartMonth - 1) If EndMonth = "" Then Exit Sub EndMonth = CInt(EndMonth) If EndMonth < StartMonth Then NbMonths = EndMonth - StartMonth + 13 EndMonth = EndMonth + 12 Else NbMonths = EndMonth - StartMonth + 1 End If 'DISPLAY EMPTY CALENDAR? strEmptyCalendar = vbNo 'strEmptyCalendar = MsgBox("Empty Calendar?", vbYesNo + vbDefaultButton2) dim arrTable(100,100) 'array used to created the transposed version of the calendar 'Create Table: 1 Header Row ' 7 days x 5 weeks = 35 day rows ' 1 Header column ' 1 column for each month strHeader = "
" & "Month" & " | " arrTable(0,0) = "" & "Month" & " | " 'First Row/col intYear = Year(Date) nextYear = intYear + 1 k = 0 LastRowOfTable = 0 For i = StartMonth To EndMonth k = k+1 MonthInNumbers = i If i > 12 Then MonthInNumbers = i - 12 intYear = nextYear End If 'Determine the last Row of the Table StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday) StrMonthEndsOnA = day(dateserial(intYear,i+1,0)) LastRowOfMonth = StrMonthStartsOnA + StrMonthEndsOnA - 1 If LastRowOfMonth > LastRowOfTable Then LastRowOfTable = LastRowOfMonth Contents = Contents & vbCrLf & "" & MonthName(MonthInNumbers) & " " & intYear & " | " arrTable(0,k) = "" & MonthName(MonthInNumbers) & " " & intYear & " | " Next Contents = Contents & vbCrLf & "||
" & WeekdayName(intWeekday, False, vbMonday) & " | " arrTable(RowCount,ColCount) = "" & left(WeekdayName(intWeekday, False, vbMonday),2) & " | " Else Contents = Contents & vbCrLf & "" & RowCount & " | " arrTable(RowCount,ColCount) = "" & RowCount & " | " End If ColCount = ColCount + 1 intYear = Year(Date) 'Month columns For i = StartMonth To EndMonth MonthInNumbers = i If i > 12 Then MonthInNumbers = i - 12 intYear = nextYear End If StrMonthStartsOnA = 1 If blAlignWeekDays Then 'e.g. if the first of the month falls on a Friday ' we need to put some grey cells before the month begins StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday) End If 'Ne If i=StartMonth Then StrFirstMonthStartsOnA = StrMonthStartsOnA intDayOfMonth = 0 If RowCount >= StrMonthStartsOnA Then intDayOfMonth = RowCount - StrMonthStartsOnA + 1 End If 'calculate date for current cell strDate = "" If intDayOfMonth > 0 Then On Error Resume Next strDate = CDate(CStr(intDayOfMonth) & " " & MonthName(MonthInNumbers) & ", " & CStr(intYear)) On Error GoTo 0 End If 'color weekends intRealWeekday = intWeekday If Not blAlignWeekDays Then On Error Resume Next intRealWeekday = Weekday(strDate) On Error GoTo 0 End If bgcolor = "#FFFFFF" If (i Mod 2 = 0) Then bgcolor = cornsilk Select Case intRealWeekday Case 6 bgcolor = wheat_light Case 7 bgcolor = wheat_dark End Select 'grey out empty cells dispDate = "" dispDateTransposed = "" If strDate = "" Then bgcolor = silver ElseIf blAlignWeekDays Then strShortMonth = MonthName(MonthInNumbers, True) strShortMonthTransposed = strShortMonth If Weekday(strDate) = 1 Or Weekday(strDate) = 7 Then strShortMonthTransposed = "" dispDate = "" & Day(strDate) & " " & strShortMonth & "" dispDateTransposed = "" & Day(strDate) & " " & strShortMonthTransposed & "" Else 'if blAlignWeekDays = False dispDate = "" & Day(strDate) & " " & WeekdayName(intRealWeekday, True, vbSunday) & "" dispDateTransposed = dispDate End If 'display date Contents = Contents & vbCrLf & "" & dispDate & " " arrTable(RowCount,ColCount) = " | " & dispDateTransposed & " "
'display appointments
If strEmptyCalendar = vbNo Then
strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
strRestriction = strRestriction & " AND [Duration] > 0"
If strDate = "" Then strRestriction = "[Start] = 1" 'no result
Set myRestrictItems = MyFolder.Restrict(strRestriction)
myRestrictItems.Sort "[Start]"
'Contents = Contents & vbCrLf & myRestrictItems.Count & " " For Each myitem In myRestrictItems blDisplay = True 'check if this appointment is in a category that we want to hide For Each strCat2Exclude In arrExcludeCategories If InStr(myitem.Categories, strCat2Exclude) Then blDisplay = False Next 'check if this is a private appointment If blShowPrivateAppointments = False And myitem.Sensitivity = 2 Then blDisplay = False blIsAllDayEvent = myitem.AllDayEvent If blAllDayEventsOnly And Not blIsAllDayEvent Then blDisplay = False 'Display the appointment If blDisplay Then strTime = "" If Not blIsAllDayEvent Then strTime = " " & Hour(myitem.Start) & ":" & Left(Minute(myitem.Start) & "0",2) strTime = strTime & "-" & Hour(myitem.End) & ":" & Left(Minute(myitem.End) & "0",2) & " " End If 'getting color 'MsgBox myitem & vbcr & vbcr & storeID & vbcr & vbcr & objCDO strColor = GetColor(myitem, storeID, objCDO) Contents = Contents & strTime & "" & myitem.Subject & vbCrLf & "" arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount)& strTime & "" & myitem.Subject & vbCrLf & "" End If Next 'myitme In myRestrictItems Else 'i.e; If strEmptyCalendar = vbYes Contents = Contents & " " arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & " " End If 'If strEmptyCalendar = vbNo Contents = Contents & vbCrLf & " | "
arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & vbCrLf & ""
ColCount = ColCount + 1
Next 'For i = StartMonth To EndMonth
Contents = Contents & vbCrLf & "
" & WeekdayName(intWeekday, False, vbMonday) & " | " Next c7contents = c7contents & vbCrLf & "
" ColCount = ColCount + 1 Next for i=0 to NbMonths For j=0 to LastRowOfTable 'filter out some unneeded cells with the if condition If InStr(arrTable(j,i),"tableHeader")=0 And InStr(arrTable(j,i),"bgcolor = '" & silver)=0 Then c7contents = c7contents & arrTable(j,i) & vbCR ColCount = ColCount +1 End If If ColCount = 7 Then ColCount = 0 c7contents = c7contents & " |