From the feedback I've received about the first public folder RSS feed sink I've come up with another version that incorporates many bug fixes and add's in some additional functionality.
The main functionality change and bug fix revolves around the publishing of the content of each public folder message. In the original sink I was using the Textdescription field which represented the text body of the email. The problem with this is that firstly the carriage returns weren't interpreted right in the XML file so if you had a long message it just appeared all stuck together with no formatting. To fix this there where two options the first was to continue using the textdescription field and then just replace any ASCII 13 characters (Line breaks in a email) with html line break characters eg
replace(Rs.fields("urn:schemas:httpmail:textdescription"),chr(13),"<br/>")
The second option and the one I've gone for is to use the urn:schemas:httpmail:htmldescription this allows for all the formatting to be retained in the XML file and this displays okay in various RSS feed readers I've tested.
The other functionality added was to change the link section so instead of linking back to the eml file that would take you to OWA if you clicked the link now it will redirect to a ASP file. This ASP file takes in two html querystrings passed in from the link in the RSS Feed and then does a webdav get on the feedfile and returns a webpage representation of that RSS feed entry. This is pretty cool because what it allows you to do is you can publish the feed file and asp file on a external web server and then allow people to access the contents of your Exchange public folders without even needing them to access your Exchange box via OWA.
To cater for the link functionality I've added a GUID node into each item entry based on the DAV:getetag field of each message. (Its possible I may regret using this field as im not 100% sure what its actually for but it was a nice unique number with no wacky characters that i could pass around, other things like Dav:href while unique i found caused problems in certain situations).
Other bug fixes include the RFC822 date fix, I've tried to get rid of all the hardcoded servernames and used two variables that are set at the top of the script instead for the webservername and feedfile name. Some small formatting changes where also made to make it more compatible across multiple RSS feed aggregates.
I recently got some webspace to post the scripts I put up on this blog so I've uploaded the complete code for the eventsink and the showmessage.asp page and they can be downloaded from http://msgdev.mvps.org/exdevblog/pubfeedv2.zip
To use the showmessage.asp page this needs to be located in the same directory as the feed file (if not you'll need to modify the code). I hope for the next version to do a complied version with a installer so you won't need to know anything about event sinks to use it. Here's the code for the new sink and showmessage.asp.
Sub ExStoreEvents_OnSave(pEventInfo, bstrURLItem, lFlags)
on error resume next
WebServer = "Intranet"
feedfile = "feedpub2.xml"
set DispEvtInfo = pEventInfo
set ADODBRec = DispEvtInfo.EventRecord
set objdom = CreateObject("MICROSOFT.XMLDOM")
Set objField = objDom.createElement("rss")
Set objattID = objDom.createAttribute("version")
objattID.Text = "2.0"
objField.setAttributeNode objattID
objDom.appendChild objField
Set objField1 = objDom.createElement("channel")
objfield.appendChild objField1
Set objField3 = objDom.createElement("link")
objfield3.text = "http://" & WebServer & "/showmessage.asp?xmlfile=" & feedfile & "&message=All"
objfield1.appendChild objField3
Set objField4 = objDom.createElement("title")
objfield4.text = "Public Folder Feed"
objfield1.appendChild objField4
Set objField5 = objDom.createElement("description")
objfield5.text = "Public Folder Feed For Path"
objfield1.appendChild objField5
Set objField6 = objDom.createElement("language")
objfield6.text = "en-us"
objfield1.appendChild objField6
Set objField7 = objDom.createElement("lastBuildDate")
objfield7.text = WeekdayName(weekday(now),3) & ", " & day(now()) & " " & Monthname(month(now()),3) & " " & year(now()) & " " & formatdatetime(now(),4) & ":00 GMT"
objfield1.appendChild objField7
Set Rs = CreateObject("ADODB.Recordset")
Set fso = CreateObject("Scripting.FileSystemObject")
Set msgobj = CreateObject("CDO.Message")
tyear = year(now()-7)
tmonth = month(now()-7)
if tmonth < 10 then tmonth = 0 & tmonth
stday = day(now()-7)
if stday < 10 then stday = 0 & stday
sttime = formatdatetime(now1,4)
qdatest = tyear & "-" & tmonth & "-" & stday & "T"
qdatest1 = qdatest & sttime & ":" & "00Z"
set Rec = CreateObject("ADODB.Record")
set Rec1 = CreateObject("ADODB.Record")
Set Conn = CreateObject("ADODB.Connection")
mailboxurl = ADODBRec.fields("Dav:parentname")
Conn.Provider = "ExOLEDB.DataSource"
Rec.Open mailboxurl, ,3
SSql = "SELECT ""DAV:href"", ""DAV:getetag"", ""DAV:contentclass"", ""urn:schemas:httpmail:htmldescription"", ""urn:schemas:httpmail:datereceived"", "
SSql = SSql & """urn:schemas:httpmail:fromemail"", ""urn:schemas:httpmail:subject"", ""DAV:ishidden"" "
Ssql = SSql & " FROM scope('shallow traversal of """ & mailboxurl & """') "
SSql = SSql & " WHERE (""urn:schemas:httpmail:datereceived"" > CAST(""" & qdatest1 & """ as 'dateTime')) AND ""DAV:isfolder"" = false"
Rs.CursorLocation = 3 'adUseServer = 2, adUseClient = 3
Rs.CursorType = 3
rs.open SSql, rec.ActiveConnection, 3
if Rs.recordcount <> 0 then
Rs.movefirst
while not rs.eof
if rs.fields("DAV:ishidden") = 0 then
Set objField2 = objDom.createElement("item")
objfield1.appendChild objField2
Set objField8 = objDom.createElement("guid")
Set objattID8 = objDom.createAttribute("isPermaLink")
objattID8.Text = "false"
objField8.setAttributeNode objattID8
objfield8.text = replace(Rs.fields("DAV:getetag"),chr(34),"")
objfield2.appendChild objField8
Set objField9 = objDom.createElement("title")
objfield9.text = rs.fields("urn:schemas:httpmail:subject")
objfield2.appendChild objField9
Set objField10 = objDom.createElement("link")
objfield10.text = "http://" & WebServer & "/showmessage.asp?xmlfile=" & feedfile & "&message=" & replace(Rs.fields("DAV:getetag"),chr(34),"")
objfield2.appendChild objField10
Set objField11 = objDom.createElement("description")
objfield11.text = Rs.fields("urn:schemas:httpmail:htmldescription")
if objfield11.text = "" then objfield11.text = "Blank"
objfield2.appendChild objField11
Set objField12 = objDom.createElement("author")
objfield12.text = rs.fields("urn:schemas:httpmail:fromemail")
objfield2.appendChild objField12
Set objField13 = objDom.createElement("pubDate")
objfield13.text = WeekdayName(weekday(rs.fields("urn:schemas:httpmail:datereceived")),3) & ", " & day(rs.fields("urn:schemas:httpmail:datereceived")) & " " & Monthname(month(rs.fields("urn:schemas:httpmail:datereceived")),3) & " " & year(rs.fields("urn:schemas:httpmail:datereceived")) & " " & formatdatetime(rs.fields("urn:schemas:httpmail:datereceived"),4) & ":00 GMT"
objfield2.appendChild objField13
set objfield2 = nothing
set objfield8 = nothing
set objfield9 = nothing
set objfield10 = nothing
set objfield11 = nothing
set objfield12 = nothing
set objfield13 = nothing
end if
rs.movenext
wend
end if
rs.close
Set objPI = objDom.createProcessingInstruction("xml", "version='1.0'")
objDom.insertBefore objPI, objDom.childNodes(0)
objdom.save("\\" & Webserver & "\wwwroot\" & feedfile)
End Sub
showmessage.asp file
<%
on error resume next
set xmlfile1 = request.querystring("xmlfile")
xmlfile = "http://" & Request.ServerVariables("SERVER_NAME") &
Request.ServerVariables("URL")
xmlfile = left(xmlfile,(instr(xmlfile,"showmessage.asp")-1)) & xmlfile1
uid = request.querystring("message")
set xmlobj = server.createobject("microsoft.xmlhttp")
xmlobj.Open "Get", xmlfile, False, "", ""
xmlobj.setRequestHeader "Accept-Language:", "en-us"
xmlobj.setRequestHeader "Content-type:", "text/xml"
xmlobj.Send
set oResponseDoc = xmlobj.responseXML
set oNodeList = oResponseDoc.getElementsByTagName("*")
For i = 0 To (oNodeList.length -2)
set oNode = oNodeList.nextNode
if oNode.Text = uid then
guid = oNode.Text
set oNode = oNodeList.nextNode
Title = oNode.Text
set oNode = oNodeList.nextNode
Link = oNode.Text
set oNode = oNodeList.nextNode
Description = oNode.Text
set oNode = oNodeList.nextNode
Author = oNode.Text
set oNode = oNodeList.nextNode
pubdate = oNode.Text
end if
Next
pubdate = replace(pubdate,"GMT","")
pubdate = cdate(Mid(pubdate,(instr(pubdate,",")+1),len(pubdate)))
set shell = server.createobject("wscript.shell")
strValueName = "HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"
minTimeOffset = shell.regread(strValueName)
toffset = datediff("h",DateAdd("n", minTimeOffset, now()),now())
pubdate = dateadd("h",toffset,pubdate)
%><table border="1" cellspacing="1" width="100%" id="table1">
<tr>
<td>Received: <%=pubdate%></td>
</tr>
<tr>
<td>From: <%=author%></td>
</tr>
<tr>
<td>Subject: <%=Title%></td>
</tr>
<tr>
<td>Message: <%=Description%></td>
</tr>
</table>
The main functionality change and bug fix revolves around the publishing of the content of each public folder message. In the original sink I was using the Textdescription field which represented the text body of the email. The problem with this is that firstly the carriage returns weren't interpreted right in the XML file so if you had a long message it just appeared all stuck together with no formatting. To fix this there where two options the first was to continue using the textdescription field and then just replace any ASCII 13 characters (Line breaks in a email) with html line break characters eg
replace(Rs.fields("urn:schemas:httpmail:textdescription"),chr(13),"<br/>")
The second option and the one I've gone for is to use the urn:schemas:httpmail:htmldescription this allows for all the formatting to be retained in the XML file and this displays okay in various RSS feed readers I've tested.
The other functionality added was to change the link section so instead of linking back to the eml file that would take you to OWA if you clicked the link now it will redirect to a ASP file. This ASP file takes in two html querystrings passed in from the link in the RSS Feed and then does a webdav get on the feedfile and returns a webpage representation of that RSS feed entry. This is pretty cool because what it allows you to do is you can publish the feed file and asp file on a external web server and then allow people to access the contents of your Exchange public folders without even needing them to access your Exchange box via OWA.
To cater for the link functionality I've added a GUID node into each item entry based on the DAV:getetag field of each message. (Its possible I may regret using this field as im not 100% sure what its actually for but it was a nice unique number with no wacky characters that i could pass around, other things like Dav:href while unique i found caused problems in certain situations).
Other bug fixes include the RFC822 date fix, I've tried to get rid of all the hardcoded servernames and used two variables that are set at the top of the script instead for the webservername and feedfile name. Some small formatting changes where also made to make it more compatible across multiple RSS feed aggregates.
I recently got some webspace to post the scripts I put up on this blog so I've uploaded the complete code for the eventsink and the showmessage.asp page and they can be downloaded from http://msgdev.mvps.org/exdevblog/pubfeedv2.zip
To use the showmessage.asp page this needs to be located in the same directory as the feed file (if not you'll need to modify the code). I hope for the next version to do a complied version with a installer so you won't need to know anything about event sinks to use it. Here's the code for the new sink and showmessage.asp.
Sub ExStoreEvents_OnSave(pEventInfo, bstrURLItem, lFlags)
on error resume next
WebServer = "Intranet"
feedfile = "feedpub2.xml"
set DispEvtInfo = pEventInfo
set ADODBRec = DispEvtInfo.EventRecord
set objdom = CreateObject("MICROSOFT.XMLDOM")
Set objField = objDom.createElement("rss")
Set objattID = objDom.createAttribute("version")
objattID.Text = "2.0"
objField.setAttributeNode objattID
objDom.appendChild objField
Set objField1 = objDom.createElement("channel")
objfield.appendChild objField1
Set objField3 = objDom.createElement("link")
objfield3.text = "http://" & WebServer & "/showmessage.asp?xmlfile=" & feedfile & "&message=All"
objfield1.appendChild objField3
Set objField4 = objDom.createElement("title")
objfield4.text = "Public Folder Feed"
objfield1.appendChild objField4
Set objField5 = objDom.createElement("description")
objfield5.text = "Public Folder Feed For Path"
objfield1.appendChild objField5
Set objField6 = objDom.createElement("language")
objfield6.text = "en-us"
objfield1.appendChild objField6
Set objField7 = objDom.createElement("lastBuildDate")
objfield7.text = WeekdayName(weekday(now),3) & ", " & day(now()) & " " & Monthname(month(now()),3) & " " & year(now()) & " " & formatdatetime(now(),4) & ":00 GMT"
objfield1.appendChild objField7
Set Rs = CreateObject("ADODB.Recordset")
Set fso = CreateObject("Scripting.FileSystemObject")
Set msgobj = CreateObject("CDO.Message")
tyear = year(now()-7)
tmonth = month(now()-7)
if tmonth < 10 then tmonth = 0 & tmonth
stday = day(now()-7)
if stday < 10 then stday = 0 & stday
sttime = formatdatetime(now1,4)
qdatest = tyear & "-" & tmonth & "-" & stday & "T"
qdatest1 = qdatest & sttime & ":" & "00Z"
set Rec = CreateObject("ADODB.Record")
set Rec1 = CreateObject("ADODB.Record")
Set Conn = CreateObject("ADODB.Connection")
mailboxurl = ADODBRec.fields("Dav:parentname")
Conn.Provider = "ExOLEDB.DataSource"
Rec.Open mailboxurl, ,3
SSql = "SELECT ""DAV:href"", ""DAV:getetag"", ""DAV:contentclass"", ""urn:schemas:httpmail:htmldescription"", ""urn:schemas:httpmail:datereceived"", "
SSql = SSql & """urn:schemas:httpmail:fromemail"", ""urn:schemas:httpmail:subject"", ""DAV:ishidden"" "
Ssql = SSql & " FROM scope('shallow traversal of """ & mailboxurl & """') "
SSql = SSql & " WHERE (""urn:schemas:httpmail:datereceived"" > CAST(""" & qdatest1 & """ as 'dateTime')) AND ""DAV:isfolder"" = false"
Rs.CursorLocation = 3 'adUseServer = 2, adUseClient = 3
Rs.CursorType = 3
rs.open SSql, rec.ActiveConnection, 3
if Rs.recordcount <> 0 then
Rs.movefirst
while not rs.eof
if rs.fields("DAV:ishidden") = 0 then
Set objField2 = objDom.createElement("item")
objfield1.appendChild objField2
Set objField8 = objDom.createElement("guid")
Set objattID8 = objDom.createAttribute("isPermaLink")
objattID8.Text = "false"
objField8.setAttributeNode objattID8
objfield8.text = replace(Rs.fields("DAV:getetag"),chr(34),"")
objfield2.appendChild objField8
Set objField9 = objDom.createElement("title")
objfield9.text = rs.fields("urn:schemas:httpmail:subject")
objfield2.appendChild objField9
Set objField10 = objDom.createElement("link")
objfield10.text = "http://" & WebServer & "/showmessage.asp?xmlfile=" & feedfile & "&message=" & replace(Rs.fields("DAV:getetag"),chr(34),"")
objfield2.appendChild objField10
Set objField11 = objDom.createElement("description")
objfield11.text = Rs.fields("urn:schemas:httpmail:htmldescription")
if objfield11.text = "" then objfield11.text = "Blank"
objfield2.appendChild objField11
Set objField12 = objDom.createElement("author")
objfield12.text = rs.fields("urn:schemas:httpmail:fromemail")
objfield2.appendChild objField12
Set objField13 = objDom.createElement("pubDate")
objfield13.text = WeekdayName(weekday(rs.fields("urn:schemas:httpmail:datereceived")),3) & ", " & day(rs.fields("urn:schemas:httpmail:datereceived")) & " " & Monthname(month(rs.fields("urn:schemas:httpmail:datereceived")),3) & " " & year(rs.fields("urn:schemas:httpmail:datereceived")) & " " & formatdatetime(rs.fields("urn:schemas:httpmail:datereceived"),4) & ":00 GMT"
objfield2.appendChild objField13
set objfield2 = nothing
set objfield8 = nothing
set objfield9 = nothing
set objfield10 = nothing
set objfield11 = nothing
set objfield12 = nothing
set objfield13 = nothing
end if
rs.movenext
wend
end if
rs.close
Set objPI = objDom.createProcessingInstruction("xml", "version='1.0'")
objDom.insertBefore objPI, objDom.childNodes(0)
objdom.save("\\" & Webserver & "\wwwroot\" & feedfile)
End Sub
showmessage.asp file
<%
on error resume next
set xmlfile1 = request.querystring("xmlfile")
xmlfile = "http://" & Request.ServerVariables("SERVER_NAME") &
Request.ServerVariables("URL")
xmlfile = left(xmlfile,(instr(xmlfile,"showmessage.asp")-1)) & xmlfile1
uid = request.querystring("message")
set xmlobj = server.createobject("microsoft.xmlhttp")
xmlobj.Open "Get", xmlfile, False, "", ""
xmlobj.setRequestHeader "Accept-Language:", "en-us"
xmlobj.setRequestHeader "Content-type:", "text/xml"
xmlobj.Send
set oResponseDoc = xmlobj.responseXML
set oNodeList = oResponseDoc.getElementsByTagName("*")
For i = 0 To (oNodeList.length -2)
set oNode = oNodeList.nextNode
if oNode.Text = uid then
guid = oNode.Text
set oNode = oNodeList.nextNode
Title = oNode.Text
set oNode = oNodeList.nextNode
Link = oNode.Text
set oNode = oNodeList.nextNode
Description = oNode.Text
set oNode = oNodeList.nextNode
Author = oNode.Text
set oNode = oNodeList.nextNode
pubdate = oNode.Text
end if
Next
pubdate = replace(pubdate,"GMT","")
pubdate = cdate(Mid(pubdate,(instr(pubdate,",")+1),len(pubdate)))
set shell = server.createobject("wscript.shell")
strValueName = "HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"
minTimeOffset = shell.regread(strValueName)
toffset = datediff("h",DateAdd("n", minTimeOffset, now()),now())
pubdate = dateadd("h",toffset,pubdate)
%><table border="1" cellspacing="1" width="100%" id="table1">
<tr>
<td>Received: <%=pubdate%></td>
</tr>
<tr>
<td>From: <%=author%></td>
</tr>
<tr>
<td>Subject: <%=Title%></td>
</tr>
<tr>
<td>Message: <%=Description%></td>
</tr>
</table>