<%@ Language=VBScript %> <%Response.Buffer = False%>

/programsandresearch/blogs/getblogs.asp

originally: http://www.oclc.org/programsandresearch/blogs/getblogs.asp

Loading
<% '******************************************************************************* ' File: getfeed.asp ' ' Purpose: Get the latest feed entry from the list of feeds below. ' ' J. Vu 07/10/2006 - Initial Version ' ' R. Bolander 09/02/2008 - Copied file and customized list of feeds. '******************************************************************************* Public Function FormatDate(ByVal strDate) Dim objRegExpr, colMatches,objMatch,arrDValues,intY,intM,intD,strWeekDay,strMonth Set objRegExpr = New regexp objRegExpr.Pattern = "[0-9]{4}-[0-9]{2}-[0-9]{2}" objRegExpr.Global = True objRegExpr.IgnoreCase = True Set colMatches = objRegExpr.Execute(strDate) For Each objMatch in colMatches arrDValues = Split(objMatch.Value ,"-") intY = arrDValues(0) intM = arrDValues(1) intD = arrDValues(2) intD = Replace(intD,"T","") strDate = intM & "/" & intD & "/" & intY strDate = CDate(strDate) strWeekDay = Left(WeekDayName(DatePart("w",strDate)),3) strMonth = Left(MonthName(DatePart("M",strDate)),3) strDate = strWeekday & ", " & intD & " " & strMonth Next FormatDate = strDate 'Clean up Set colMatches = Nothing Set objRegExpr = Nothing End Function Public Function FormatDate2(ByVal strDate) Dim arrValues arrValues = Split(strDate ," ") If (Ubound(arrValues) > 0) Then strDate = arrValues(2) & " " & arrValues(1) & "," & arrValues(3) intM = Month(strDate) If (Len(intM) = 1) Then intM = "0" & intM End If strDate = arrValues(3) & "-" & intM & "-" & arrValues(1) & "T" End If FormatDate2 = strDate End Function Function Push(ByRef mArray, ByVal mValue) Dim intCounter Dim intElementCount If IsArray(mArray) Then If IsArray(mValue) Then ' Set ubound value once only intElementCount = UBound(mArray) ReDim Preserve mArray(intElementCount + UBound(mValue) + 1) ' Using for...next is more efficient & quicker than for..each For intCounter = 0 to UBound(mValue) mArray(intElementCount + intCounter + 1) = mArray(intCounter) Next Else ReDim Preserve mArray(UBound(mArray) + 1) mArray(UBound(mArray)) = mValue End If Else If IsArray(mValue) Then mArray = mValue Else mArray = Array(mValue) End If End If Push = UBound(mArray) End Function Function SortArray (ByRef sArray) Dim i, j, temp For i = UBound(sArray) - 1 To 0 Step -1 For j= 0 to i If sArray(j) < sArray(j+1) then temp=sArray(j+1) sArray(j+1)=sArray(j) sArray(j)=temp End If Next Next SortArray = sArray End Function %> <% Dim URLToRSS,MaxNumberOfItems,MainTemplateHeader,MainTemplateFooter,ItemTemplate Dim ErrorMessage,xmlHttp,RSSXML,xmlDOM,RSSItems,RSSItemsCount,j,i,RSSItem,child Dim RSStitle,RSSlink,RSSdescription,ItemContent,RSSElements,RSSdate,RSSChannelsCount Dim objLst,RSSTitle1, strURL, intIndex, arrList,strBlog,intI,arrItems,aParts,intQ Dim strDescription, regEx ' Change this to however many URLs you have Dim arrURLs(5) arrURLs(1) = "http://orweblog.oclc.org/index.xml" arrURLs(2) = "http://outgoing.typepad.com/outgoing/index.rdf" arrURLs(3) = "http://weibel-lines.typepad.com/weibelines/index.rdf" arrURLs(4) = "http://feeds.feedburner.com/Hangingtogetherorg" arrURLs(5) = "http://q6.oclc.org/" ' ##### max number of displayed items ##### MaxNumberOfItems = 1 ' ##### Main template constants 'MainTemplateHeader = "" 'MainTemplateFooter = "
" ' ##### ' ##### Item template. ' ##### {LINK} will be replaced with item link ' ##### {TITLE} will be replaced with item title ' ##### {DESCRIPTION} will be replaced with item description ItemTemplate = "

{TITLE1}
{TITLE2}
{DESCRIPTION}

" ' ##### Error message that will be displayed if not items etc ErrorMessage = "Error has occured while trying to process " &URLToRSS & "
Please contact web-master" ' ================================================ For intIndex = 1 To Ubound(arrURLS) Set xmlHttp = Server.CreateObject("MSXML2.XMLHTTP.3.0") xmlHttp.Open "Get", arrURLs(intIndex), false xmlHttp.Send() RSSXML = xmlHttp.ResponseText Set xmlDOM = Server.CreateObject("MSXML2.DomDocument.3.0") xmlDOM.async = false xmlDOM.LoadXml(RSSXML) Set xmlHttp = Nothing ' clear HTTP object If (InStr(arrURLs(intIndex),"atom.xml") > 0) Then Set RSSItems = xmlDOM.getElementsByTagName("entry") ' collect all "items" from downloaded RSS Else Set RSSItems = xmlDOM.getElementsByTagName("item") ' collect all "items" from downloaded RSS End If Set objLst = xmlDOM.getElementsByTagName("*") For i = 0 to (objLst.length - 1) If objLst.item(i).nodeName = "pubDate" OR objLst.item(i).nodeName = "dc:date" OR objLst.item(i).nodeName = "published" Then RSSdate = objLst.item(i).text Exit For End If Next For i = 0 to (objLst.length - 1) If objLst.item(i).nodeName = "title" Then RSSTitle1= objLst.item(i).text Exit For End If Next Set xmlDOM = Nothing ' clear XML RSSItemsCount = RSSItems.Length-1 If RSSItemsCount > 0 Then ' writing Header ' if RSSItemsCount > 0 then ' Response.Write MainTemplateHeader ' End If j = -1 For i = 0 To RSSItemsCount Set RSSItem = RSSItems.Item(i) for each child in RSSItem.childNodes Select case lcase(child.nodeName) case "title" RSStitle = child.text case "link" If (child.text = "") Then If (child.Attributes.length > 0) Then RSSlink = child.GetAttribute("href") End If Else RSSlink = child.text End If case "description" RSSdescription = child.text case "dc:date" RSSdate = child.text case "published" RSSdate = child.text case "pubDate" RSSdate = child.text End Select next 'RSSdate = Mid(RSSdate,1,11) 'RSSdate = FormatDate(Mid(RSSdate,1,11),1) j = J+1 if J 0 then ' Response.Write MainTemplateFooter 'End If Next arrList = SortArray(arrList) For intI = 0 To 2 strDescription = "" arrItems = Split(arrList(intI), "::") RSSdate = FormatDate(Mid(arrItems(0),1,11)) RSSdescription = arrItems(4) ' Strip out Links set regEx = New RegExp regEx.Global = true regEx.IgnoreCase = True regEx.Pattern = "\s*((\n|.)+?)\s*" RSSdescription = regEx.Replace(RSSdescription, "../%24157688") ItemContent = Replace(ItemTemplate,"{LINK}",arrItems(3)) ItemContent = Replace(ItemContent,"{TITLE1}",arrItems(2)) Do While Instr(RSSdescription, " ") > 0 RSSdescription = Replace(RSSdescription, " ", " ") Loop aParts = Split(RSSdescription, " ") Redim Preserve aParts(20) For intQ = 0 To 20 strDescription = strDescription & " " & aParts(intQ) Next strDescription = Replace(strDescription, "

", "") strDescription = strDescription & "..." ItemContent = Replace(ItemContent,"{DESCRIPTION}",strDescription) Response.Write Replace(ItemContent,"{TITLE2}",arrItems(1)) ItemContent = "" Next ' Response.End ' uncomment this line if you need to finalize output %>