Sub DisplayYearlyCalendar() 'copyright Nick Roemer 'http://niveauverleih.blogspot.com/ 'version 1.9, 22 Jan 2009 'copy and paste this code into your Outlook Visual Basic Editor 'Therefore just press Alt+F11 in your Outlook 'Right click on 'Modules' 'choose 'insert/module' 'paste the code in the big white window on the right hand side 'Run it from Outlook via Tools/Macro/Macros/DisplayYearlyCalendar 'this macro will display your Outlook appointments over a period of several months 'or an empty calendar to print out 'the output is an html file that is displayed with Internet Explorer '------------------------------------------------------------------- 'list here the categories that you want to hide 'e.g. arrExcludeCategories = Array("@home", "Personal") arrExcludeCategories = Array() 'Set this to TRUE if you want to display private appointments Const blShowPrivateAppointments = True '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 'Set this to TRUE if you want to display AllDayEvents only blAllDayEventsOnly = False '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 forwrite = 2 Set objShell = CreateObject("WScript.Shell") strTempFolder = objShell.ExpandEnvironmentStrings("%TEMP%") strHtmlFile = strTempFolder & "\YearlyCalendar.html" 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 strEmptyCalendar = MsgBox("Empty Calendar?", vbYesNo + vbDefaultButton2) 'Create Table: 1 Header Row ' 7 days x 5 weeks = 35 day rows ' 1 Header column ' 1 column for each month Contents = "Yearly Calendar" Contents = Contents & vbCrLf & "" 'header row Contents = Contents & vbCrLf & "" Contents = Contents & vbCrLf & "" 'First Row intYear = Year(Date) nextYear = intYear + 1 For i = StartMonth To EndMonth MonthInNumbers = i If i > 12 Then MonthInNumbers = i - 12 intYear = nextYear End If Contents = Contents & vbCrLf & "" Next Contents = Contents & vbCrLf & "" If strEmptyCalendar = vbNo Then Set onNamespace = GetNamespace("MAPI") 'change the following line to 'Set MyFolder = onNamespace.PickFolder.Items' 'if you want to select your calendar folder manually (if you have several) Set MyFolder = onNamespace.GetDefaultFolder(9).Items MyFolder.Sort "[Start]" MyFolder.IncludeRecurrences = True End If 'Day Rows RowCount = 0 For week = 1 To 6 'The macro was originally written for the case blAlignWeekDays = True For intWeekday = 1 To 7 'Therefore the I used a double loop: weeks then weekdays RowCount = RowCount + 1 'First column Contents = Contents & vbCrLf & "" If blAlignWeekDays Then Contents = Contents & vbCrLf & "" Else Contents = Contents & vbCrLf & "" End If 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 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) 'Weekday(DateAdd("d", -1, strDate)) On Error GoTo 0 End If bgcolor = "#FFFFFF" Select Case intRealWeekday Case 7 bgcolor = wheat_light Case 1 bgcolor = wheat_dark End Select If blAlignWeekDays Then bgcolor = "#FFFFFF" Select Case intRealWeekday Case 6 bgcolor = wheat_light Case 7 bgcolor = wheat_dark End Select End If 'grey out empty cells dispDate = "" If strDate = "" Then bgcolor = silver ElseIf blAlignWeekDays Then dispDate = "" & Day(strDate) & " " & MonthName(MonthInNumbers, True) & "" Else 'if blAlignWeekDays = False dispDate = "" & Day(strDate) & " " & WeekdayName(intRealWeekday, True, vbSunday) & "" End If 'display date Contents = Contents & vbCrLf & "" Next Contents = Contents & vbCrLf & "" If blAlignWeekDays And week = 6 And intWeekday = 2 Then Exit For 'latest possible day in last week is Tuesday (31 days from Sunday) If (Not blAlignWeekDays) And RowCount = 31 Then Exit For Next If (Not blAlignWeekDays) And RowCount = 31 Then Exit For Next 'create the html file Set filesys = CreateObject("Scripting.FileSystemObject") Set f = filesys.OpenTextFile(strHtmlFile, forwrite, True) f.Write Contents 'display the html file Set wshell = CreateObject("WScript.Shell") strCommand = "iexplore """ & strHtmlFile & """" wshell.run (strCommand) End Sub Function GetColor(objAppt) 'http://ms-office-forum.net/forum/archive/index.php/t-143024.html On Error Resume Next 'Important! Const CdoPropSetID1 = "0220060000000000C000000000000046" Const CdoAppt_Colors = "0x8214" Set objCDO = CreateObject("MAPI.Session") objCDO.Logon "", "", False, False If objAppt.Class = olAppointment Then Set objMsg = objCDO.GetMessage(objAppt.EntryID, objAppt.Parent.StoreID) Set colFields = objMsg.Fields Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1) 'objField.Value is 0-8 '1=Important, 2=Business,.... ColorCode = objField.Value Else ColorCode = 0 End If GetColor = "" Select Case ColorCode Case 1 'Important GetColor = "FA8072" Case 2 'Business GetColor = "6495ED" Case 3 'Personal GetColor = "9ACD32" Case 4 'Vacation GetColor = "F5F5DC" Case 5 'Must Attend F4A460 GetColor = "F4A460" Case 6 'Travel Required GetColor = "AFEEEE" Case 7 'Needs preparation GetColor = "C1BC5B" Case 8 'Birthday GetColor = "9370DB" Case 9 'Anniversary GetColor = "6FA898" Case 10 'Phonecall GetColor = "F5C94D" End Select End Function
" & "Month" & "" & MonthName(MonthInNumbers) & " " & intYear & "
" & WeekdayName(intWeekday, False, vbMonday) & "" & RowCount & "" & dispDate & " " '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) & "h" If Minute(myitem.Start) <> 0 Then strTime = strTime & Minute(myitem.Start) strTime = strTime & " " End If Contents = Contents & strTime & "" & myitem.Subject & vbCrLf & "" End If Next Else Contents = Contents & "

" End If Contents = Contents & vbCrLf & "