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 = "Yearly Calendar" 'NOTE: We are trying to use the available space efficiently to put all appointments on one sheet of paper 'You should play around with the "font-size:50%" bit, depending on how packed your calendar is strTableHeader = Contents & vbCrLf & "" 'header row Contents = Contents & vbCrLf & "" Contents = Contents & vbCrLf & "" arrTable(0,0) = "" '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 & "" arrTable(0,k) = "" Next Contents = Contents & vbCrLf & "" If strEmptyCalendar = vbNo Then Set MyFolder = MyCalendar.Items storeID = MyCalendar.storeID MyFolder.IncludeRecurrences = True MyFolder.Sort "[Start]" 'create CDO session in order to get appointment label colors strProfileInfo = strServer & vbLf & strMailbox 'You must add a Reference to Microsoft CDO version 1.21. On Error Resume next Set objCDO = CreateObject("MAPI.Session") 'IMPORTANT: log on using a new MAPI session with a dynamically created profile 'we can't simply reuse the existing MAPI session -> script will not retrieve colors for all appointments objCDO.Logon "", "", False, True, 0, False, strProfileInfo & "rtrtrtr" ErrNum = err.number On Error GoTo 0 If ErrNum<>0 Then MsgBox "Could not create MAPI session to retrieve appointment colors. Will continue without colors." End If 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 I used a double loop: weeks then weekdays ColCount = 0 RowCount = RowCount + 1 'First column Contents = Contents & vbCrLf & "" If blAlignWeekDays Then Contents = Contents & vbCrLf & "" arrTable(RowCount,ColCount) = "" Else Contents = Contents & vbCrLf & "" arrTable(RowCount,ColCount) = "" 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 & "" arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & vbCrLf & "" ColCount = ColCount + 1 Next 'For i = StartMonth To EndMonth Contents = Contents & vbCrLf & "" If blAlignWeekDays And RowCount = LastRowOfTable 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 'For intWeekday = 1 To 7 If (Not blAlignWeekDays) And RowCount = 31 Then Exit For If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For Next 'For week = 1 To 6 'create transposed contents tcontents = "
" & "Month" & "" & "Month" & "" & MonthName(MonthInNumbers) & " " & intYear & "" & MonthName(MonthInNumbers) & " " & intYear & "
" & WeekdayName(intWeekday, False, vbMonday) & "" & left(WeekdayName(intWeekday, False, vbMonday),2) & "" & RowCount & "" & RowCount & "" & 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 & "
" for i=0 to NbMonths tcontents = tcontents & "" for j=0 to LastRowOfTable tcontents = tcontents & arrTable(j,i) & vbCR next tcontents = tcontents & "" & vbCR Next tcontents = tcontents & "
" 'create contents "7columns" c7contents = "" 'First Row - Weekdaynames c7contents = c7contents & vbCrLf & "" For intWeekday = 1 To 7 c7contents = c7contents & vbCrLf & "" Next c7contents = c7contents & vbCrLf & "" ColCount = 0 'Add some gray cells For i=1 To StrFirstMonthStartsOnA-1 c7contents = c7contents & "" 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 & "" & vbCR c7contents = c7contents & "" End If next Next c7contents = c7contents & "
" & WeekdayName(intWeekday, False, vbMonday) & "
" 'create the html files Set filesys = CreateObject("Scripting.FileSystemObject") Set F = filesys.OpenTextFile(strHtmlFile, ForWriting, True) F.Write strHeader & strTableHeader & Contents Set F = Nothing Set F = filesys.OpenTextFile(strHtmlFileTransposed, ForWriting, True) F.Write tcontents Set F = Nothing Set F = filesys.OpenTextFile(strHtmlFile7Columns, ForWriting, True) F.Write c7contents Set F = Nothing Set filesys = Nothing 'display the html files strCommand = "iexplore """ & strHtmlFile & """" objShell.run (strCommand) strCommand = "iexplore """ & strHtmlFileTransposed & """" objShell.run (strCommand) strCommand = "iexplore """ & strHtmlFile7Columns & """" objShell.run (strCommand) 'display containing folder strCommand = "explorer """ & strTempFolder & """" objShell.run (strCommand) Set objShell = Nothing Set objFSO = Nothing on error resume next objCDO.Logoff on error goto 0 Set objCDO = Nothing Set MyFolder = Nothing Set MyCalendar = Nothing Set onNamespace = Nothing Set OL = Nothing End Sub '************************************************************************************* '***************** FUNCTIONS ************************************** '************************************************************************************* Function GetColor(objAppt, storeID, objCDO) 'http://ms-office-forum.net/forum/archive/index.php/t-143024.html On Error Resume Next 'Important! Const CdoPropSetID1 = "0220060000000000C000000000000046" Const CdoAppt_Colors = "0x8214" 'MsgBox objAppt.EntryID & vbcr & vbcr & storeID & vbcr & vbcr & objCDO If objAppt.Class = 26 Then ' = appointment 'ColorCode = objCDO.GetMessage(objAppt.EntryID).Fields.Item(CdoAppt_Colors, CdoPropSetID1).Value ColorCode = objCDO.GetMessage(objAppt.EntryID, storeID).Fields.Item(CdoAppt_Colors, CdoPropSetID1).Value 'objField.Value is 0-8 '1=Important, 2=Business,.... 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 On Error GoTo 0 End Function Public Function GetExchangeServer(strMailbox) 'Root to where registry stores the outlook settings MainKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" 'get the default outlook profile option stored in the registry and add it to the key path Const HKEY_LOCAL_MACHINE = &H80000002 Const HKEY_USERS = &H80000003 strComputer ="." GetRegKeyStrValue strComputer, HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName", username Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" & strComputer & "/root/default:StdRegProv") oReg.EnumKey HKEY_USERS,"", arrSubKeys For Each subkey In arrSubKeys sKey = subkey & "\Software\Microsoft\Windows\CurrentVersion\Explorer" REGusername = "" GetRegKeyStrValue strComputer, HKEY_USERS, sKey, "Logon User Name", REGusername If ucase(REGusername)=ucase(username) Then MainKeyPath = subkey & "\" & MainKeyPath GetRegKeyStrValue strComputer, HKEY_USERS, MainKeyPath, "DefaultProfile", DefaultProfile MainKeyPath = MainKeyPath & DefaultProfile GetRegKeyBinValue strComputer, HKEY_USERS, MainKeyPath & "\9207f3e0a3b11019908b08002b2a56c2", "01023d00", arrBinary 'msgbox MainKeyPath For i = 0 To UBound(arrBinary) KeyValue = KeyValue & Chr(arrBinary(i)) Next 'msgbox Keyvalue NumFolders = Len(KeyValue) / 16 For x = 1 To NumFolders 'Get next key name from list KeyName = Mid(KeyValue, ((x - 1) * 16) + 1, 16) KeyName = BinarySTRToText(Trim(KeyName)) PSTKeyName = MainKeyPath & "\" & KeyName StoreType = "" If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3d09", arrBinary) <> "Failed" Then For i = 0 To UBound(arrBinary)-2 Step 2 StoreType = StoreType & Chr(arrBinary(i)) Next End If IF StoreType = "MSPST MS" or StoreType = "MSUPST MS" Then If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then For i = 0 To UBound(arrBinary)-2 Step 2 strMailboxFound = strMailboxFound & Chr(arrBinary(i)) Next End If Else If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then For i = 0 To UBound(arrBinary)-2 Step 2 PstKeyValue = PstKeyValue & Chr(arrBinary(i)) Next strMailboxfound = PstKeyValue PstKeyValue = "" End If End If If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f662b", arrBinary) <> "Failed" Then For i = 0 To UBound(arrBinary)-2 Step 2 PstKeyValue = PstKeyValue & Chr(arrBinary(i)) Next strServer = PstKeyValue If instr(strMailboxFound, strMailbox) Then 'MsgBox strMailboxFound & " " & strMailbox GetExchangeServer = strMailboxFound & "|" & strServer End If PstKeyValue = "" End If Next End If Next End Function Function GetRegKeyBinValue(sComputer, hTree, sKey, sValueName, sValue) Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv") lResult = oRegistry.GetBinaryValue(hTree, sKey, sValueName, sValue) If (lResult = 0) And (Err.Number = 0) Then GetRegKeyBinValue = "Succeeded" Else GetRegKeyBinValue = "Failed" sValue = "" End If Set oRegistry = Nothing End Function Function GetRegKeyStrValue(sComputer, hTree, sKey, sValueName, sValue) Dim oRegistry Dim lResult Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv") lResult = oRegistry.GetStringValue(hTree, sKey, sValueName, sValue) If (lResult = 0) And (Err.Number = 0) Then GetRegKeyStrValue = sValue Else GetRegKeyStrValue = "Failed" sValue = "" End If Set oRegistry = Nothing End Function Private Function BinarySTRToText(BinaryStr) For i = 1 To Len(BinaryStr) xstr = Mid(BinaryStr, i, 1) xlong = CLng(Asc(xstr)) xvar = Hex(xlong) xstr = CStr(xvar) If Len(xstr) = 1 Then xstr = "0" & xstr BinarySTRToText = BinarySTRToText & xstr Next End Function