Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 06-Sep-2010 21:35

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: intermediate Code area: Outlook Expert Techniques Printer Friendly Version
Title: HTMLCalendar.TXT
Description: This script will export the contents of a mailbox calendar in Exchange 5.5 to a UNC share on web server. Used to display conference room calendar availability for the next 7 months.
Date: 01-Sep-2004 08:03
Code level: intermediate
Code area: Outlook Expert Techniques
Posted by: Eric Woodford
Body: <SCRIPT RunAt=Server Language=VBScript> Option Explicit ' NAME: HTMLCalendar.Txt ' FILE DESCRIPTION: Exports all meetings out of default calendar, and posts the results to a shared network folder. ' Originally designed to help avoid corruption of calendars during in conference room ' calendars using the ExchangeCode auto-accept script. Uses CSS page to organizer ' small calendar with links to right side of view. ' NOTE: ' Uses Mailbox Display Name for HTML filename, therefore, display name cannot contain OS default characters ' * \ ? etc. ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Author: ' Eric Woodford (ericwoodford@yahoo.com ' Send me an e-mail if you'd like the CSS sheets I've designed for this application. ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' GLOBAL VARIABLES '-----------------------------------------------------------------' Dim g_sDiagLog 'Debug String for Agent Log. Dim g_sTraceMsg 'Debug String for Trace Message. Dim g_blnTraceMsg 'Trace messages will be posted for each event ' CONSTANTS '-----------------------------------------------------------------' ' Version 1.1 ' Future - Convert time to AM/PM ' - show meetings starting yesterday. ' 1.1 - resolved issue with "Cancelled" appointments. ' 1.0 - original release ' ' BusyStatus Property for AppointmentItem object Const CdoFree = 0 'Free ' Display Type Const CdoPR_DISPLAY_TYPE = &H39000003 'Display Type Tag Const CdoDistList = 1 'Public Distribution List ' MAPI Property Tags Const CdoPR_START_DATE = &H600040 'Start Date for filter Const CdoPR_END_DATE = &H610040 'End Date for filter 'MAPI FreeBusy Property Tags Const PR_RECALCULATE_FREEBUSY = &H10F2000B Const PR_FREEBUSY_DATA = &H686C0102 'Color codes for the table. const bgcolor1="#FFFFFF" ' odd color const bgcolor2="#ccccff" ' even color const bgcolor0="#6699ff" ' title bar color const strUNCPath="\\mywebsrv\ConferenceRoomReservations\" private function removespaces(cname) ' function converts our conference room naming standards Location ... to a valid filename. ' could not get standard replace() function to work, used SPLIT to remove spaces in display name. dim x dim s dim newstr dim strbits s = right(cname, len(cname)-1) strbits = split(s," ") newstr = strBits(0) For x = 1 To UBound(strbits) newstr = newstr & strbits(x) Next removespaces = newstr & ".HTML" end function Public Sub Folder_OnTimer ' On each Timer event, script will generate a HTML file with all meetings booked in calendar. Dim dtmstartTime ' start time for filter default = NOW() dim dtmEndTime ' end time for filter default = NOW() + 7 months dim objCdoSession ' container for current session Dim colMsgs ' Messages Collection - meet filter requirements Dim objMsgFilter ' Filter for Messages Collection Dim objAppt ' Current working Appointment object dim objCalendar ' Current calendar folder, default current user Dim MyArray ' array for building main content dim myCalendar ' array for building side calendar dim counter ' # of meetings found in calendar dim WebContent ' string container for web page content Dim Loopcount ' for loop counter dim bgcolor ' place holder for bgcolor tag in code dim strOrganizer ' organizer for meeting string holder dim pdm,pdd ' Values for previous month, day - transitition on colors dim cdm, cdd, cdy ' current working day, month values Dim objFileSystem ' connect to fso to create file dim objFile ' current file connection Dim objAttachment ' container for attachment (HTML file when sending via e-mail) Dim oFolderOutbox ' object link to folder for outgoing e-mail message Dim oNotifyMsg ' object connect to new message dim strEmailAddress ' value for e-mail address dim oRecipient ' recipient container for new message dim colorstep ' container for current color value on table dim startminutes ' string container for HTML content Start Time Minutes dim endminutes ' string container for HTML content End Time Minutes dim x ' variable for loops, dim dow ' day of week for when to start new week dim workingdate ' start of week date for buidling small selection calendar, = Saturday of current week dim monthstr ' 3 letter value for current month JAN, FEB, MAR, etc. small calendar dim ConferenceRoomName dim strDayOfWeek ' String Value for Day of Week. ' define new session, initialize variables, build filter and apply Call DebugAppend("OnTimer Event Starting: "& NOW(), True, False) Set objCdoSession = EventDetails.Session UpdateFreeBusy dtmstarttime=now() ' start time = right now. dtmEndTime = dateadd("M",7, Now()) ' end date = 7 months from right now... set objcalendar = objCdoSession.GetDefaultFolder(0) Set colMsgs = objCalendar.Messages Set objMsgFilter = colMsgs.Filter objMsgFilter.Fields.Add CdoPR_START_DATE, dtmEndTime objMsgFilter.Fields.Add CdoPR_END_DATE, dtmStartTime Set objAppt = colMsgs.GetFirst call DebugAppend("Starting Processing of Meetings", True, False) If (not objAppt Is Nothing) Then 'Found appointments = met filter condition) Set objAppt = colMsgs.GetFirst ReDim MyArray(2000,6) ' define arrays for use. 2000 = 9 meetings a day for 210 days + float reDim MyCalendar(220,2) ' 220 = 7 months 30 days on average + float for x = 0 to 219 ' initialize array with all zeros = no meetings on this day. mycalendar(x,0) = 0 next dow = weekday(now()) ' what day of the week is today (Saturday=1, Monday=2,...Sunday=7) if dow <>1 then ' if day of week <> Sunday then continue workingdate = dateadd("D",(-1dow)+1,Now()) ' Set WorkingDate= date on Sunday. else workingdate = now() end if Counter = 0 ' count # of meeting requests found in calendar Do While (Not objAppt Is Nothing) if counter > 2000 then exit do ' stop looping if over 2000 meetings found. On Error Resume Next strOrganizer = CStr(objAppt.sender.Name) If (Not objAppt.BusyStatus = CdoFree) Then 'Make sure the appointment is not "free" = Holidays myarray(counter,0) = objappt.starttime myarray(counter,1) = objappt.endtime myarray(counter,2) = objappt.subject if (instr(strOrganizer,"/O=DELTA")=0) and (instr(strOrganizer,"")=0) then myarray(counter,3) = strOrganizer else x = instr(objappt.subject,":") if x > 0 then myArray(counter,3) = left(objappt.subject,x-1) else x = instr(objappt.subject,"/") if x > 0 then myArray(counter,3) = left(objappt.subject,x-1) else myArray(counter,3) = objappt.subject end if end if end if strOrganizer = "" myarray(counter,4) = objappt.isrecurring mycalendar((datediff("D",workingdate,myarray(counter,0))),0)=1 End If Set objAppt = colMsgs.GetNext counter = counter + 1 Loop End If Set ObjAppt = Nothing Call DebugAppend("Starting Build of Web Page -> (" & counter & ") Items found", True, False) if counter > 0 then pdm = 0 pdd = 0 colorstep = 0 ConferenceRoomName = objCDOSession.CurrentUser ConferenceRoomName = removespaces(ConferenceRoomName) ' assign conference room name as field without spaces. WebContent = "<HTML> <title> Report for "& objCDOSession.CurrentUser & "</title>" & vbcrlf WebContent = webcontent & "<meta http-equiv='refresh' content='600'>" & vbcrlf ' set web page to refresh every 10 minutes. webcontent = webcontent & "<link rel='stylesheet' type='text/css' href='mycss.css' media='all'/>" & vbcrlf webcontent = webcontent & "<BODY><h3>"&objCDOSession.CurrentUser &"</h3>"&vbcrlf&"<small> Last Update: "&cstr(dtmstarttime)& "</small><br> "&vbcrlf webcontent = webcontent & "<a name=top></a>" & vbcrlf webcontent = webcontent & "<div id='Leftcontent'>" '~~~~~~~~~~~~~~~~ GENERATE MAIN WEB CONTENT. ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ for loopcount = 0 to counter - 1 cdm = datepart("M",myarray(loopcount,0)) cdd = datepart("D",myarray(loopcount,0)) cdy = datepart("yyyy",myarray(loopcount,0)) dow = weekday(myarray(loopcount,0)) ' found canceled appointments in calendar are in year 1899. if cdy <> 1899 then if (pdm <> cdm ) or (pdd <> cdd ) then ' if new date, create new table. ' generates string value of day of week. Could not get Format("WWWW",date) to work select case dow case 1 strDayOfWeek = "Sunday" case 2 strDayOfWeek = "Monday" case 3 strDayOfWeek = "Tuesday" case 4 strDayOfWeek = "Wednesday" case 5 strDayOfWeek = "Thursday" case 6 strDayOfWeek = "Friday" case 7 strDayOfWeek = "Saturday" End Select if pdd = 0 then ' if first run, then start new table. WebContent = WebContent & "<br><h2><a name="& cdm & "/" & cdd &">"& cdm & "/" & cdd &" - "&strDayOfWeek &"</h2><Table cellspacing=0 cellpadding=0 width=100% border=0> <TR BGCOLOR="&bgcolor0&"> <TH WIDTH=50> START </TH><TH WIDTH=50> END </TH><th></th><th>SUBJECT</TH><TH align=Right>ORGANIZER</TH></TR>" else ' else assume first table created and start next table. WebContent = WebContent & "</table> <small><a href=#top>top</a></small>"&vbcrlf&"<br><h2><a name="& cdm & "/" & cdd &">"& cdm & "/" & cdd &" - "&strDayOfWeek &"</h2><Table cellspacing=0 cellpadding=0 width=100% border=0> <TR BGCOLOR="&bgcolor0&"> <TH WIDTH=50> START </TH><TH WIDTH=50> END </TH><th></th><th>SUBJECT</TH><TH align=Right>ORGANIZER</TH></TR>" end if pdm = cdm pdd = cdd colorstep=0 end if if colorstep = 0 then ' alternates column color, uses constants defined at top.. bgcolor = bgcolor1 colorstep = 1 else bgcolor = bgcolor2 colorstep = 0 end if ' could not get string formatting to work, so evaluating nymber value to generate starting 0 for 00, 01, 02 etc. minutes.. if datepart("n",myarray(loopcount,0))< 10 then startminutes = "0" & cstr(datepart("n",myarray(loopcount,0))) else startminutes = datepart("n",myarray(loopcount,0)) end if if datepart("n",myarray(loopcount,1)) < 10 then endminutes = "0" & cstr(datepart("n",myarray(loopcount,1))) else endminutes = datepart("n",myarray(loopcount,1)) end if ' if recurring appt, then put OWA recurring symbol. GIF in same folder as everything else. if myarray(loopcount,4) = True then WebContent = WebContent &"<TR bgcolor="& bgcolor &"><TD><p>" & datepart("h",myarray(loopcount,0)) &":"& startminutes & "</p></TD><TD><p>"& datepart("h",myarray(loopcount,1)) &":"& endminutes &"</P></td><td><img src='recur.gif' alt='Recurring Appointment'></td><td><p>" & myarray(loopcount,2) & "</p></TD><TD align='RIGHT'><p> <a href='mailto:" & MyArray(LoopCount,3) & "?subject="&myarray(loopcount,2)&"'> "& MyArray(LoopCount,3) &"</A></p></TD></TR>" else WebContent = WebContent &"<TR bgcolor="& bgcolor &"><TD><p>" & datepart("h",myarray(loopcount,0)) &":"& startminutes & "</p></TD><TD><p>"& datepart("h",myarray(loopcount,1)) &":"& endminutes &"</P></td><td></td><td><p>" & myarray(loopcount,2) & "</p></TD><TD align=right><p> <a href='mailto:" & MyArray(LoopCount,3) & "?subject="&myarray(loopcount,2)&"'> "& MyArray(LoopCount,3) &"</A></p></TD></TR>" end if end if next WebContent = WebContent & "</Table><br></div>"&vbcrlf '************* GENERATE MINI CALENDAR AT TOP OF REPORT ********************* webcontent = webcontent &"<div id='rightcontent'><small> Click on a date below to view meetings planned on that date.</small><h4><center>CALENDAR</center></h4>" & vbcrlf webcontent = webcontent & "<Table cellspacing=1 cellpadding=1 border=0 align=center><tr><th></th><th><small>SUN</small></th><th><small>MON</small></th><th><small>TUE</small></th><th><small>WED</small></th><th><small>THU</small></th><th><small>FRI</small></th><th><small>SAT</small></th></tr><tr>" for x = 0 to 219 cdm = datepart("M",dateadd("D",x,WorkingDate)) cdd = datepart("D",dateadd("D",x,WorkingDate)) dow = weekday(dateadd("D",x,workingdate)) select case cdm case 1 bgcolor= "#9966ff" monthstr = "Jan" case 2 bgcolor= "##9999ff" monthstr = "Feb" case 3 bgcolor= "#99ccff" monthstr = "Mar" case 4 bgcolor= "#cc99ff" monthstr = "Apr" case 5 bgcolor= "#99FFff" monthstr = "May" case 6 bgcolor= "#ccffcc" monthstr = "Jun" case 7 bgcolor= "#9966ff" monthstr = "Jul" case 8 bgcolor= "#9999ff" monthstr = "Aug" case 9 bgcolor= "#99ccff" monthstr = "Sep" case 10 bgcolor= "#99FFff" monthstr = "Oct" case 11 bgcolor= "#cccccc" monthstr = "Nov" case 12 bgcolor= "#ccffcc" monthstr = "Dec" end select if x = 0 then webcontent = webcontent & "<td><small>"&monthstr&"</small></td>" end if if mycalendar(x,0) = 1 then webcontent = webcontent & "<td bgcolor="&bgcolor&"><a href='#"&cdm&"/"&cdd&"'><small>"&cdd&"</small></a></td>" else webcontent = webcontent & "<td bgcolor="&bgcolor&"><small>"&cdd&"</small></td>" end if if (dow = 7) then webcontent = webcontent & "</tr>"&vbcrlf&"<tr><td><small>"&monthstr&"</small></td>" end if next webcontent = webcontent & "</table> <BR> </div>" webcontent = webcontent & "</BODY></HTML>" Call DebugAppend("Writing file to shared folder: '"&strUNCPath & ConferenceRoomName &"'", True, False) Set objFileSystem = CreateObject("Scripting.FileSystemObject") Set objFile = objFileSystem.OpenTextFile(strUNCPath & ConferenceRoomName, 2,True) objFile.Write WebContent ' this is your HTML message body objFile.Close ' file is created Else ' no entries found in calendar... Call DebugAppend("---------> No Entries found in this calendar", True, False) WebContent = "<HTML> <title> Report for "& objCDOSession.CurrentUser & "</title>" & vbcrlf WebContent = webcontent & "<meta http-equiv='refresh' content='600'>" & vbcrlf ' set web page to refresh every 10 minutes. webcontent = webcontent & "<link rel='stylesheet' type='text/css' href='mycss.css' media='all'/>" & vbcrlf webcontent = webcontent & "<BODY><h3>"&objCDOSession.CurrentUser &"</h3>"&vbcrlf&"<small> Last Update: "&cstr(dtmstarttime)& "</small><br> "&vbcrlf Webcontent = webcontent & "<h4> No content has been found for this calendar. </h4>" &vbcrlf webcontent = webcontent & "</BODY></HTML>" Set objFileSystem = CreateObject("Scripting.FileSystemObject") Call DebugAppend("Writing file to shared folder: '"&strUNCPath & ConferenceRoomName &"'", True, False) Set objFile = objFileSystem.OpenTextFile(strUNCPath & ConferenceRoomName, 2,True) objFile.Write WebContent ' this is your HTML message body objFile.Close ' file is created end if Set objCDoSession = Nothing Set oFolderOutbox = Nothing Set oNotifyMsg = Nothing Set oRecipient = Nothing Call DebugAppend("OnTimer Event Finished: "& NOW(), True, False) Script.Response = vbCrLf & g_sDiagLog End Sub '-----------------------------------------------------------------' ' Name: UpdateFreeBusyData ' Desc: Updates the users freebusy data ' Parm: none ' Retn: none '-----------------------------------------------------------------' Private Sub UpdateFreeBusy Dim objCdoSession 'CDO session Dim objRoot Dim objFreeBusyFolder Dim objMessageList Dim objMessage Dim objField Call DebugAppend("Starting -> UpdateFreeBusy Information " & Time, True, False) 'Get CDO Session Set objCdoSession = EventDetails.Session 'Session Object 'Get Root Folder --- IPM_ROOT folder Set objRoot = objCdoSession.GetFolder("") 'Open FreeBusy Data folder Set objFreeBusyFolder = objRoot.Folders.Item("FreeBusy Data") 'Get List of message in FreeBusy Data Folder set objMessageList = objFreeBusyFolder.Messages 'Loop through messages looking for message with LocalFreebusy as subject For Each objMessage In objMessageList ' Update message If objMessage.Subject = "LocalFreebusy" Then Set objField = objMessage.Fields objField.Item(PR_FREEBUSY_DATA).Delete objField.Add PR_RECALCULATE_FREEBUSY, False objMessage.Update Exit For End If Next End sub '-----------------------------------------------------------------' ' Name: DebugAppend ' Desc: Simple Debugging Function ' Parm: String Text, Bool ErrorFlag '-----------------------------------------------------------------' Private Sub DebugAppend(bstrParm, blnDiagLog, blnErrChkFlag) If blnErrChkFlag = True Then If Err.Number <> 0 Then If g_blnTraceMsg = True Then g_sTraceMsg = g_sTraceMsg & bstrParm & "-" & _ CStr(Err.Number) & Err.Description & vbCrLf End If g_sDiagLog = g_sDiagLog & bstrParm & "-" & _ CStr(Err.Number) & Err.Description & vbCrLf Err.Clear End If Else If g_blnTraceMsg = True Then g_sTraceMsg = g_sTraceMsg & bstrParm & vbCrLf End If If blnDiagLog = True Then g_sDiagLog = g_sDiagLog & bstrParm & vbCrLf End If End If End Sub </script>
All 5comments

	Page [ 1 ]
	Eric Woodford 22-Sep-2004 11:57 I have revised this script a few times now. Found this version was memory and cpu intensive. Working with Sue to post code in ZIP format to this website.
	Athif 22-Mar-2005 08:32 Will this work for Exchange 2003 too. You said it works for 5.5 only. Is there any such script available for Windows 2003. Thanks, Athif
	Sue Mosher 23-Mar-2005 08:56 Since later version still support scripting, I'd expect it to work. But it would be better to port it to an event sink.
	Eric Woodford 23-Mar-2005 12:45 I have not tested it. I would think that you could simply provide permissions to the mailbox folder and avoid the whole concern with scripts. Exchange 2000+ has excellent web connectivity, that you should be able to provide web links directly into the conference room calendars. My main reason for developing this script was to get around the Exchange 5.5 problems of allowing Outlook users to view the calendar. Outlook corrupts the local copy of the free/busy information in Exchange 5.5.
	Anele 15-Aug-2005 16:26 do this program for me using built in functions which displays a numeric position of the day enterd by the user using vb6.0
	Page [ 1 ]

name email