Creating a Summary Email of all appointments within a Users Calendar for given period

This is another script that might come in handy for people trying to deal with DST affected appointments. Whether you choose to Rebase your appointments with the Exchange Time Zone Update Tool or not with the number of appointments and complexity of the actions you are performing you can't be 100 % sure of covering everything so you might want to send an email to users that contains a summary of what actions you have taken (or not), what problems there might be and a summary of all current appointments in their calendar that might be affected. To make things a bit easier all the appointments are hyperlinked via Outlook links so the user can click the appointment within the summary email and have that appointment or instance of the appointment open in Outlook.

I had a bit of version madness with this one for a number of reasons I started out with a CDO 1.2 version (mainly because i had most of the code already done) but I had a few problems with CDO 1.2 when trying to hyperlink to Recurring appointments. When using the EntryID from CDO it always links back to the master instance of a appointment when used in a Outlook link while not that undesirable it gets a little confusing especially if the appointment is a exception to a recurring appointment. I switched to using WebDAV which does give a EntryID that allows you to link to the instance of the recurring appointment but this only works when Outlook is being used in Online mode. If outlook is in Cached mode then the links to recurring appointments don't work. (For the Outlook links I'm using the Outlook:EntryID format)

The script works by going though all the appointments in the affected period and then compiling the start and end times as well as subject and locations and then grouping the information by the organizer of the appointment into html table rows. These table rows are then grouped by organizer using a scripting dictionary object which acts as a basic hashtable in VBS. At the end of the report a HTML email is created the first contains some verbage to explain what the email is about and then a table that first lists all the appointments and meetings the user has created as well as separate tables that lists the appointments from organizers that the user is scheduled to attend within the affected period.

The WebDAV version of the script uses the Admin virtual root directory to access the user calendars this gets around the need for the user running the script to have rights in the users mailbox and should be able to be run successfully using just delegated Exchange Admin rights. To work out the correct path to use for the Admin virtual root the script includes a ADSI query that gets the default SMTP FQDN from the default recipient policy.

The report is sent via email to do the send I've used OWA there where a few reasons for this at first I was using CDOSYS (the code is commented out if you find the OWA version doesnt work you could fall back to this method) but found that Outlook 2003 had a habit of blocking the links because it believed the message was forged so using OWA got around this problem . To cater for instances where you might be using Forms Based Authentication I created a FBA version that does a synthetic form logon and handles the OWA cookies.

The script takes the servername and mailbox alias you want to run it against as command-line parameters Its important to use the correct mailbox alias because this in turn is used to look up the users displayname and email address in Active Directory which is used to then group the appointments properly. You also need to configure one script variable with the name of the account you want to sent the message from via OWA. eg

owOwaURL ="http://" & snServername & "/exchange/" & mnMailbox & "/Drafts"

By default it tries to use the current users mailbox this may or may not succeed depending on the rights the user that is running the script has.

The FBA version needs to be configured further with details of the OWA logon to be used to send the email the following variables need to be set.

snOWAServername = "servername.com"
owaMailbox = "userName"
domain = "Domain"
strpassword = "Password"

I've put a downloadable version of cdo and webdav version here with the CDO version i put some extra logic in so i wont create outlook hyperlinks for recurring appointments. The webDAV script looks like

snServername = wscript.arguments(0)
mnMailbox = wscript.arguments(1)
Set sdMeetOrgs = CreateObject("Scripting.Dictionary")
datefrom = "2007-03-11T00:00:00Z"
dateto = "2007-04-01T00:00:00Z"

snOWAServername = "servername.com"
owaMailbox = "username"
domain = "domain"
strpassword = "password"
owOwaURL ="https://" & snOWAServername & "/exchange/" & owaMailbox & "/Drafts/"

set shell = createobject("wscript.shell")
strValueName = "HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"
minTimeOffset = shell.regread(strValueName)
toffset = datediff("h",DateAdd("n", minTimeOffset, now()),now())

set req = createobject("microsoft.xmlhttp")
set com = createobject("ADODB.Command")
set conn = createobject("ADODB.Connection")
Set iAdRootDSE = GetObject("LDAP://RootDSE")
strNameingContext = iAdRootDSE.Get("configurationNamingContext")
strDefaultNamingContext = iAdRootDSE.Get("defaultNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
polQuery = "<LDAP://" & strNameingContext &amp;
">;(&(objectCategory=msExchRecipientPolicy)(cn=Default
Policy));distinguishedName,gatewayProxy;subtree"
Com.ActiveConnection = Conn
Com.CommandText = polQuery
Set plRs = Com.Execute
while not plRs.eof
for each adrobj in plrs.fields("gatewayProxy").value
if instr(adrobj,"SMTP:") then dpDefaultpolicy =
right(adrobj,(len(adrobj)-instr(adrobj,"@")))
next
plrs.movenext
wend
DnameQuery = "<LDAP://" & strDefaultNamingContext &amp; ">;(mailnickname=" &
mnMailbox & ");distinguishedName,DisplayName,mail;subtree"
Com.ActiveConnection = Conn
Com.CommandText = DnameQuery
Set dsRs = Com.Execute
while not dsRs.eof
dnDisplayName = dsRs.fields("DisplayName")
emEmailaddress = dsRs.fields("mail")
dsRs.movenext
Wend
wscript.echo dnDisplayName
mbMailboxURI = "http://" & snServername &amp; "/exadmin/admin/" & dpDefaultpolicy &
"/mbx/" & mnMailbox & "/Calendar/"
wscript.echo mbMailboxURI
call procfolder(mbMailboxURI)

sub procfolder(strURL)
strQuery = "<?xml version=""1.0""?><D:searchrequest xmlns:D = ""DAV:""
xmlns:b=""urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/"">"
strQuery = strQuery & "<D:sql>SELECT ""DAV:displayname"",
""urn:schemas:httpmail:subject"", "
strQuery = strQuery & """DAV:creationdate"", "
strQuery = strQuery & """http://schemas.microsoft.com/mapi/proptag/0x0FFF0102""
As EntryID, "
strQuery = strQuery & """urn:schemas:httpmail:fromname"",
""urn:schemas:calendar:dtstart"", ""urn:schemas:calendar:dtend"","
strQuery = strQuery & " ""urn:schemas:calendar:location"",
""http://schemas.microsoft.com/mapi/apptstateflags"" FROM scope('shallow
traversal of """
strQuery = strQuery & strURL &amp; """') Where ""DAV:ishidden"" = False AND
""DAV:contentclass"" = 'urn:content-classes:appointment' AND "
strQuery = strQuery & " NOT ""urn:schemas:calendar:instancetype"" = 1 AND "
strQuery = strQuery & """urn:schemas:calendar:dtstart"" &lt;= CAST(""" & dateto
& """ as 'dateTime') AND "
strQuery = strQuery &amp; """urn:schemas:calendar:dtend"" &gt;= CAST(""" & datefrom
& """ as 'dateTime')</D:sql></D:searchrequest>"
req.open "SEARCH", strURL, false
req.setrequestheader "Content-Type", "text/xml"
req.setRequestHeader "Translate","f"
req.send strQuery
wscript.echo req.status
If req.status >= 500 Then
wscript.echo "Error: " & req.responsetext
ElseIf req.status = 207 Then
set oResponseDoc = req.responseXML
set oDisplayNameNodes = oResponseDoc.getElementsByTagName("a:displayname")
set oHrefNodes = oResponseDoc.getElementsByTagName("a:href")
set oSubject = oResponseDoc.getElementsByTagName("d:subject")
set oEndTime = oResponseDoc.getElementsByTagName("e:dtend")
Set oStartTime = oResponseDoc.getElementsByTagName("e:dtstart")
Set oLocation = oResponseDoc.getElementsByTagName("e:location")
Set oAppstate = oResponseDoc.getElementsByTagName("f:apptstateflags")
Set oFromname = oResponseDoc.getElementsByTagName("d:fromname")
Set oEntryID = oResponseDoc.getElementsByTagName("EntryID")
For i = 0 To (oDisplayNameNodes.length -1)
set oNode = oDisplayNameNodes.nextNode
set oNode1 = oHrefNodes.nextNode
set oNode2 = oSubject.nextNode
set oNode3 = oEndTime.nextNode
Set oNode4 = oStarttime.nextNode
Set oNode5 = oLocation.nextNode
Set oNode6 = oAppstate.nextNode
Set oNode7 = oFromname.nextNode
Set oNode8 = oEntryID.nextNode
wscript.echo oNode2.text
wscript.echo oNode3.text
wscript.echo oNode4.text
wscript.echo oNode5.text
wscript.echo oNode6.text
wscript.echo Octenttohex(oNode8.nodeTypedValue)
soOrgnizer = ""
soOrgnizer = oNode7.text
sdStartDate =
dateadd("h",toffset,DateSerial(Mid(oNode4.text,1,4),Mid(oNode4.text,6,2),Mid(oNode4.text,9,2))
&amp; " " & Mid(oNode4.text,12,8))
edEndDate =
dateadd("h",toffset,DateSerial(Mid(oNode3.text,1,4),Mid(oNode3.text,6,2),Mid(oNode3.text,9,2))
&amp; " " & Mid(oNode3.text,12,8))
wscript.echo soOrgnizer
wscript.echo
trReportBody = ""
trReportBody = trReportBody &amp; "<tr>" & vbcrlf
trReportBody = trReportBody & "<td align=""center"" width=""20%"">" &
sdStartDate &amp; " </td>" & vbcrlf
trReportBody = trReportBody & "<td align=""center"" width=""20%"">" & edEndDate
& "&nbsp;</td>" & vbcrlf
trReportBody = trReportBody & "<td align=""center"" width=""30%""><a
href=""outlook:" & Octenttohex(oNode8.nodeTypedValue) & """>" & oNode2.text &
"</a> </td>" & vbcrlf
trReportBody = trReportBody & "<td align=""center"" width=""15%"">" &
oNode5.text & "&nbsp;</td>" & vbcrlf
If oNode6.text <> 0 then
trReportBody = trReportBody & "<td align=""center"" width=""15%"">" & soOrgnizer
&amp; " </td>" & vbcrlf
trReportBody = trReportBody & "</tr>" & vbcrlf
If sdMeetOrgs.exists(soOrgnizer) Then
sdMeetOrgs(soOrgnizer) = sdMeetOrgs(soOrgnizer) & trReportBody
Else
sdMeetOrgs.Add soOrgnizer,trReportBody
End if
Else
trReportBody = trReportBody & "<td align=""center"">NA </td>" & vbcrlf
trReportBody = trReportBody & "</tr>" & vbcrlf
If sdMeetOrgs.exists(dnDisplayName) Then
sdMeetOrgs(dnDisplayName) = sdMeetOrgs(dnDisplayName) & trReportBody
Else
sdMeetOrgs.Add dnDisplayName,trReportBody
End If
End if
Next
Else
End If

Call WriteandSendReport()

end sub

Sub WriteandSendReport()
vbVerbage = "<p><b><font face=""Arial"" color=""#000080"">Due to change blah
blah the following " _
& "Meetings and Appointments scheduled between the 11th March and 1st of April
may potential be 1" _
& "hour incorrect. The following is a list of appointments from your calender
that may be " _
& "affected its recommended blah blah</font></b></p>"
rpReport = rpReport & vbVerbage & vbcrlf
rpReport = rpReport & "<p><b><font face=""Arial"" color=""#000080"">Meeting's
and Appointments Organized by You</font></b></p>" & vbcrlf
rpReport = rpReport & "<table border=""1"" width=""100%"">" & vbcrlf
rpReport = rpReport & " <tr>" & vbcrlf
rpReport = rpReport & "<td align=""center"" bgcolor=""#000080""
width=""20%""><b><font color=""#FFFFFF"">Start Time</font></b></td>" & vbcrlf
rpReport = rpReport & "<td align=""center"" bgcolor=""#000080""
width=""20%""><b><font color=""#FFFFFF"">End time</font></b></td>" & vbcrlf
rpReport = rpReport & "<td align=""center"" bgcolor=""#000080""
width=""30%""><b><font color=""#FFFFFF"">Subject</font></b></td>" & vbcrlf
rpReport = rpReport & "<td align=""center"" bgcolor=""#000080""
width=""15%""><b><font color=""#FFFFFF"">Location</font></b></td>" & vbcrlf
rpReport = rpReport & "<td align=""center"" bgcolor=""#000080""
width=""15%""><b><font color=""#FFFFFF"">Organizer</font></b></td>" & vbcrlf
rpReport = rpReport & "</tr>" & vbcrlf
rpReport = rpReport & sdMeetOrgs(dnDisplayName)
rpReport = rpReport &amp; "</table>" & vbcrlf
rpReport = rpReport & "<p><b><font face=""Arial"" color=""#000080"">Meeting You
are Scheduled to Attended</font></b></p>" & vbcrlf

For Each kyOrg In sdMeetOrgs.Keys
If kyOrg <> dnDisplayName Then
rpReport = rpReport & "<p><b><font face=""Arial"" color=""#000080"">Organized By
: " & kyOrg & "</font></b></p>"
rpReport = rpReport & "<table border=""1"" width=""100%"">" & vbcrlf
rpReport = rpReport & sdMeetOrgs(kyOrg)
rpReport = rpReport &amp; "</table>" & vbcrlf
End if
Next


'Set objEmail = CreateObject("CDO.Message")
'objEmail.From = "user@domain"
'objEmail.To = "user@domain"
'objEmail.Subject = "Appointment Summary for DST change"
'objEmail.htmlbody = rpReport
'objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")
= 2
'objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")
= "servername"
'objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
'objEmail.Configuration.Fields.Update
'objEmail.Send

strusername = domain &amp; "\" & owaMailbox
szXml = "destination=https://" & snOWAServername & "/exchange&flags=0&username="
& strusername
szXml = szXml &amp; "&password=" & strpassword & "&SubmitCreds=Log
On&amp;forcedownlevel=0&trusted=0"
req.Open "post", "https://" & snOWAServername & "/exchweb/bin/auth/owaauth.dll",
False
req.send szXml
reqhedrarry = split(req.GetAllResponseHeaders(), vbCrLf,-1,1)
for i = lbound(reqhedrarry) to ubound(reqhedrarry)
if instr(lcase(reqhedrarry(i)),"set-cookie: sessionid=") then reqsessionID =
right(reqhedrarry(i),len(reqhedrarry(i))-12)
if instr(lcase(reqhedrarry(i)),"set-cookie: cadata=") then reqcadata=
right(reqhedrarry(i),len(reqhedrarry(i))-12)
next

szXml = ""
szXml = szXml & "Cmd=send" & vbLf
szXml = szXml &amp; "MsgTo=" & emEmailaddress & vbLf
szXml = szXml & "MsgCc=" & vbLf
szXml = szXml &amp; "MsgBcc=" & vbLf
szXml = szXml &amp; "urn:schemas:httpmail:importance=1" & vbLf
szXml = szXml &amp; "http://schemas.microsoft.com/exchange/sensitivity-long=" & vbLf

szXml = szXml &amp; "urn:schemas:httpmail:subject=Appointment Summary for DST
change" & vbLf
szXml = szXml &amp; "urn:schemas:httpmail:htmldescription=<!DOCTYPE HTML PUBLIC " _

& """-//W3C//DTD HTML 4.0 Transitional//EN""><HTML DIR=ltr><HEAD><META
HTTP-EQUIV" _
& "=""Content-Type"" CONTENT=""text/html; charset=utf-8""></HEAD><BODY><DIV>" _

& "<FONT face='Arial' color=#000000 size=2>" & rpReport & "</font>" _
& "</DIV></BODY></HTML>" & vbLf

req.Open "POST", owOwaURL, False, "", ""
req.setRequestHeader "Accept-Language:", "en-us"
req.setRequestHeader "Content-type:", "application/x-www-UTF8-encoded"
req.SetRequestHeader "cookie", reqsessionID
req.SetRequestHeader "cookie", reqCadata
req.setRequestHeader "Content-Length:", Len(szXml)
req.Send szXml
Wscript.echo req.responseText

wscript.echo "Report Sent"

End Sub

Function Octenttohex(OctenArry)
ReDim aOut(UBound(OctenArry))
For i = 1 to UBound(OctenArry) + 1
if len(hex(ascb(midb(OctenArry,i,1)))) = 1 then
aOut(i-1) = "0" & hex(ascb(midb(OctenArry,i,1)))
else
aOut(i-1) = hex(ascb(midb(OctenArry,i,1)))
end if
Next
Octenttohex = join(aOUt,"")
End Function