Publish a Resource Calender as Web page script    Download Script

 The following script is simular to my other article except this script  is designed to produce a Web page for a resource such as a company car that will , show its status (busy or available) and show all of the booking for the resource over a seven day period. Here's is a sample of the page it will produce. This script uses ADO in conjunction with exoledb and some simple file system commands to create a HTML output file

How it works

For details of the workings of this script please see my other article . What is different in this script is firstly the time query retrieves all calendar appointments for 7 days. And an extra section has been added in the html creation section that adds the day the resource has been booked on by using the weekday and weekdayname functions.

set WshShell = CreateObject("WScript.Shell")
rem on error resume next
Set Rs = CreateObject("ADODB.Recordset")
Set fso = CreateObject("Scripting.FileSystemObject")
now1 = convertUTC(now(), 18, 0)
now2 = convertUTC(date & " " & timevalue("23:59:59"), 18, 0) + 6
tyear = year(now1)
etyear = year(now2)
tmonth = month(now1)
etmonth = month(now2)
if tmonth < 10 then
	tmonth = 0 & tmonth
end if
if etmonth < 10 then
	etmonth = 0 & etmonth
end if
stday = day(now1)
etday = day(now2)
if stday < 10 then
	stday = 0 & stday
end if
if etday < 10 then
	etday = 0 & etday
end if
sttime = formatdatetime(now1,4)
ettime = formatdatetime(now2,4)
qdatest = tyear & "-" & tmonth & "-" & stday & "T"
qdateed = etyear & "-" & etmonth & "-" & etday & "T"
qdatest1 = qdatest & sttime & ":" & "00Z"
qdatesed = qdateed & ettime & ":" & "00Z" 
set Rec = CreateObject("ADODB.Record")
Set Conn = CreateObject("ADODB.Connection")
CalendarURL = "file://./backofficestorage/yourdomain.com/MBX/resource/calendar/"
Conn.Provider = "ExOLEDB.DataSource"
Rec.Open CalendarURL
Set Rs.ActiveConnection = Rec.ActiveConnection
Rs.Source = "SELECT ""DAV:href"", " & _
                  " ""urn:schemas:httpmail:subject"", " & _
                  " ""urn:schemas:calendar:dtstart"", " & _
                  " ""urn:schemas:calendar:dtend"", " & _
		  " ""urn:schemas:calendar:organizer"", " & _
		  " ""DAV:contentclass"" " & _
            	  "FROM scope('shallow traversal of """ & CalendarURL & """') " & _
		 "WHERE (""urn:schemas:calendar:dtend"" >= CAST(""" & qdatest1 & """ as 'dateTime')) " & _
                 "AND (""urn:schemas:calendar:dtend"" <= CAST(""" & qdatesed & """ as 'dateTime'))" & _
		 " AND ""DAV:contentclass"" = 'urn:content-classes:appointment'" & _
		 " ORDER BY ""urn:schemas:calendar:dtstart"" ASC"

Rs.Open
if Rs.recordcount <> 0 then 
Rs.movefirst
while not rs.eof
	if convertUTC(rs.Fields("urn:schemas:calendar:dtstart").value, 0, 18) <= now() then
		if fopen <> 1 then
			mbusy = 1
			set wfile =  fso.opentextfile("d:\scripts\rbusy1.htm",2,true)
			wfile.write "<tr>" & vbCrLf
   			wfile.write "<td width=""32%""><font color=""#800080"">" & rs.Fields("urn:schemas:httpmail:subject").value & "</td>" & vbCrLf
 			wfile.write "<td width=""20%""><font color=""#800080"">" & weekdayname(weekday(convertUTC(rs.Fields("urn:schemas:calendar:dtstart").value, 0, 18))) & " " & FormatDateTime(convertUTC(rs.Fields("urn:schemas:calendar:dtstart").value, 0, 18), 3) & "</td>" & vbCrLf
 			wfile.write "<td width=""20%""><font color=""#800080"">" & weekdayname(weekday(convertUTC(rs.Fields("urn:schemas:calendar:dtend").value, 0, 18))) & " " & FormatDateTime(convertUTC(rs.Fields("urn:schemas:calendar:dtend").value, 0, 18), 3) & "</td>" & vbCrLf
			wfile.write "<td width=""30%""><font color=""#800080"">" & replace(rs.Fields("urn:schemas:calendar:organizer").value,chr(34)," ")  & "</td>" & vbCrLf
  			wfile.write "</tr>" & vbCrLf	
			wfile.write "</table>" & vbCrLf	  
  			wfile.close
		end if		
	else
		if fopen <> 1 then
			set wfile =  fso.opentextfile("d:\scripts\todayr1.htm",2,true)
			fopen = 1
		end if 
		wfile.write "<tr>" & vbCrLf
   		wfile.write "<td width=""32%""><font color=""#800080"">" & rs.Fields("urn:schemas:httpmail:subject").value & "</td>" & vbCrLf
 		wfile.write "<td width=""20%""><font color=""#800080"">" & weekdayname(weekday(convertUTC(rs.Fields("urn:schemas:calendar:dtstart").value, 0, 18))) & " " & FormatDateTime(convertUTC(rs.Fields("urn:schemas:calendar:dtstart").value, 0, 18), 3) & "</td>" & vbCrLf
 		wfile.write "<td width=""20%""><font color=""#800080"">" & weekdayname(weekday(convertUTC(rs.Fields("urn:schemas:calendar:dtend").value, 0, 18))) & " " & FormatDateTime(convertUTC(rs.Fields("urn:schemas:calendar:dtend").value, 0, 18), 3) & "</td>" & vbCrLf
		wfile.write "<td width=""30%""><font color=""#800080"">" & replace(rs.Fields("urn:schemas:calendar:organizer").value,chr(34)," ") & "</td>" & vbCrLf
  		wfile.write "</tr>" & vbCrLf	
		end if
	rs.movenext
wend
end if
rs.close
if fopen = 1 then
	wfile.write "</table>" & vbCrLf	 
	wfile.write "<p>&nbsp;</p>The page will automatically refresh every 30 Seconds Last updated on " & now() & vbCrLf
	wfile.write "</body>" & vbCrLf
	wfile.write "</html>" & vbCrLf
	wfile.close 	 	 
else
	set wfile =  fso.opentextfile("d:\scripts\todayr1.htm",2,true)
	wfile.write "</table>" & vbCrLf	 
	wfile.write "<p>&nbsp;</p>The page will automatically refresh every 30 Seconds Last updated on " & now() & vbCrLf
	wfile.write "</body>" & vbCrLf
	wfile.write "</html>" & vbCrLf
	wfile.close 
end if
if mbusy <> 1 then
	strrun = WshShell.run ("cmd.exe /C copy d:\scripts\rheada.htm + d:\scripts\rbod.htm + d:\scripts\todayr1.htm D:\scripts\ccar.htm",1,TRUE)
else
	strrun = WshShell.run ("cmd.exe /C copy d:\scripts\rheadb.htm + d:\scripts\rbusy1.htm + d:\scripts\rbod.htm + d:\scripts\todayr1.htm D:\scripts\ccar.htm",1,TRUE)
end if

function convertUTC(dtconv, tzfr, tzTo)
	Set tapptobj = CreateObject("CDO.Appointment")
	Set tapptconf = CreateObject("CDO.Configuration")
	tapptobj.Configuration = tapptconf
	tapptconf.Fields("urn:schemas:calendar:timezoneid").Value = tzfr
	tapptconf.Fields.Update
	tapptobj.StartTime = dtconv
	tapptconf.Fields("urn:schemas:calendar:timezoneid").Value = tzTo
	tapptconf.Fields.Update
	convertutc = tapptobj.StartTime
end function

Using this Code

Before you can use this code you need to first change the parameters of the code to suit your mail system and file paths.

Change CalendarURL = "file://./backofficestorage/yourdomain.com/MBX/resource/calendar/" to your own domain name if your not sure what it is have a look at the M: drive on your server and change d:\scripts to your own path where you have placed the HTM template files

Template files
In the script download there is another zip file called templatehtms these are the Html template files that are used in the copy command explained in the last section of the code. You need to unzip these files and place them in the path that you have defined in the code (eg d:\scripts). If you want you can modify the Htm files yourself you should however be careful to have a look at the format used in these files as they are designed to be copied together to produce an end file. (If your going to do any mods I recommend you just use Notepad to change text names.)

You also need to find the CdoTimeZoneId for your timezone and change each of the convertUTC function calls so it sends and converts the correct times for your timezone. To run this code you must execute it under a user context that has access to the resource calendar you might want to look at using the NT schedule service to run this code on a regular basis during the day (for example I used a scheduled task that runs it every 5 minutes)

Download Script