%@ Language=VBScript %>
<%Response.Buffer = False%>
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 = " {TITLE1} 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 ", "") 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 %> |