<% Option Explicit Response.Buffer = True '====================================== 'RSS Newsfeed Grabber v1.0 'Written By: Eric Walters 'Email: lfs@digitalrice.com ' 'For more ASP scripts and the latest 'version of this script, point your 'browser to: ' http://lfs.digitalrice.com/asp/ ' 'Notes: '1) Must have write and delete access 'in this script's directory. ' '2) News file format: url,name 'Each line should contain the URL to 'a RSS newsfeed and a unique name 'seperated by a comma. ' '====================================== %> <% Dim xmlObj,xmlHTTP,objRoot,objLinks,objChannel,objChild Dim i,arrFeeds(),arrFeed,strMyName,strXMLfile,strFile,intDelay,strXML,strTemp,strNewsfile Dim blnCache,objFSO,objFolder,objFile,blnFound,strCache 'Initialize. Set objFSO = Server.CreateObject("Scripting.FileSystemObject") strMyName = Request.ServerVariables("SCRIPT_NAME") strNewsfile = "newsfeed.ini" 'File that the URL and feed names are stored in intDelay = 30 'Time-to-live for cached XML files blnCache = True 'True = Cache files; False = Get file every time 'Creates a timestamp string Function GetDateTime() If Month(Now) < 10 Then GetDateTime = GetDateTime & "0" & Month(Now) Else GetDateTime = GetDateTime & Month(Now) If Day(Now) < 10 Then GetDateTime = GetDateTime & "0" & Day(Now) Else GetDateTime = GetDateTime & Day(Now) GetDateTime = GetDateTime & Year(Now) If Hour(Now) < 10 Then GetDateTime = GetDateTime & "0" & Hour(Now) Else GetDateTime = GetDateTime & Hour(Now) If Minute(Now) < 10 Then GetDateTime = GetDateTime & "0" & Minute(Now) Else GetDateTime = GetDateTime & Minute(Now) If Second(Now) < 10 Then GetDateTime = GetDateTime & "0" & Second(Now) Else GetDateTime = GetDateTime & Second(Now) End Function 'Converts a GetDateTime() timestamp back to a date Function SplitDateTime(strDate) strTemp = Left(strDate, 4) strDate = Right(strDate, 10) SplitDateTime = Left(strTemp, 2) & "/" & Right(strTemp, 2) strTemp = Left(strDate, 6) strDate = Right(strDate, 4) SplitDateTime = SplitDateTime & "/" & Left(strTemp, 4) & " " & Right(strTemp, 2) & ":" & Left(strDate, 2) & ":" & Right(strDate, 2) End Function 'This function was designed to remove a tag or tag property. 'Specifically, items that cause parsing errors in the XMLDOM. Function RemoveItem(strInput, strItem, strEnd) Dim strRem If InStr(strInput, strItem) > 0 Then strRem = Mid(strInput,InStr(strInput,strItem),InStr(InStr(strInput,strItem) + Len(strItem),strInput,strEnd) - InStr(strInput,strItem) + 1) RemoveItem = Replace(strInput, strRem, "") Else RemoveItem = strInput End If End Function If objFSO.FileExists(Server.MapPath(".") & "/" & strNewsfile) Then Set objFile = objFSO.OpenTextFile(Server.MapPath(".") & "/" & strNewsfile, 1, False) i = 0 Do While Not objFile.AtEndOfStream ReDim Preserve arrFeeds(1,i) strTemp = objFile.Readline If Not Instr(strTemp, ",") = 0 Then arrFeed = Split(strTemp, ",") arrFeeds(0,i) = arrFeed(0) arrFeeds(1,i) = arrFeed(1) i = i + 1 End If Loop Else ReDim arrFeeds(0,0) arrFeeds(0,0) = "http://www.allheadlinenews.com/rss/agriculture.xml" arrFeeds(0,1) = "sofotex" End If set xmlObj = Server.CreateObject("Microsoft.XMLDOM") For i = 0 to UBound(arrFeeds,2) strXMLfile = arrFeeds(0,i) strFile = arrFeeds(1,i) strCache = "" blnFound = False If blnCache Then 'Begin caching code Set objFolder = objFSO.GetFolder(Server.MapPath(".")) For Each objFile In objFolder.Files If Right(objFile.Name, Len(strFile & ".xml")) = strFile & ".xml" Then 'Do we have a match for the XML file? If DateDiff("n", SplitDateTime(Left(objFile.Name, 14)), Now) < intDelay Then 'Is the file within the time-to-live? If Not strCache = "" Then 'Have we found a cache file for this already? If DateDiff("n", SplitDateTime(Left(objFile.Name, 14)), Now) < DateDiff("n", SplitDateTime(Left(strCache, 14)), Now) Then 'Is this file younger than the other one? blnFound = True 'Yup. Delete the old one. objFSO.DeleteFile(Server.MapPath("./" & strCache)) strCache = objFile.Name Else 'Nope. Delete it. objFSO.DeleteFile(objFile.Path) End If Else 'Haven't found one yet, this one will work for now. blnFound = True strCache = objFile.Name End If Else 'Too old. Delete it. objFSO.DeleteFile(objFile.Path) End If End If Next End If If blnCache and blnFound Then 'We're caching files and we've found a cached file. Load it. xmlObj.async = False xmlObj.Load(Server.MapPath("./" & strCache)) Else 'We're either not caching files, or we didn't find one. Get a new copy. Set xmlHTTP = Server.CreateObject("Microsoft.XMLHTTP") xmlHTTP.Open "GET",strXMLfile,false xmlHTTP.SetRequestHeader "Content-type", "text/xml" xmlHTTP.Send strXML = xmlHTTP.ResponseText 'Microsoft's XMLDOM can't handle encoding or doctypes too well, 'so I'm removing the appropriate tags and properties. strXML = RemoveItem(strXML, " encoding=""", """") strXML = RemoveItem(strXML, "") 'This loop changes every character to VB compatible characters. 'Since we're not changing encoding in the files, this will 'fix some errors. I know it's not efficient, but it works. Dim x For x = 1 to Len(strXML) strXML = Left(strXML, x-1) & Chr(Asc(Mid(strXML, x, 1))) & Right(strXML, Len(strXML) - x) Next xmlObj.async = False xmlObj.loadXML(strXML) Set xmlHTTP = Nothing End If 'Got a problem? Handle it. If Not xmlObj.parseError.errorCode = 0 then With xmlObj.parseError Response.Write "[" & strFile & "] Error: " & .reason & "
" & VbCrLf Response.Write "[" & strFile & "] Line: " & .line & " (" & .linepos & ") - " & .srcText & "
" & VbCrLf End With Else 'If we're caching and we don't have a cached file, create one. If blnCache and Not blnFound and Len(strXML) > 0 Then xmlObj.Save(Server.MapPath(".") & "/" & GetDateTime & "_" & strFile & ".xml") 'Start dumping parsed XML into the Response.Buffer Response.Write "" & VbCrLf set objRoot = xmlObj.documentElement 'Set the root of the XML object set objChannel = objRoot.selectSingleNode("channel") 'Get the channel object for newsfeed info set objLinks = objRoot.getElementsByTagName("item") 'Get a collection of all the items in the channel 'Dump the channel info into the buffer 'Response.Write "" & objChannel.selectSingleNode("title").text & " - Show Descriptions" Response.Write "" & objChannel.selectSingleNode("title").text & " - " Response.Write "" & VbCrLf & " " & VbCrLf & "" & VbCrLf & "

" & VbCrLf 'Dump the links into the buffer, if "Show Descriptions" is clicked, 'then we dump those into the buffer, too. For Each objChild in objLinks Response.Write " " & objChild.selectSingleNode("title").text & " " & VbCrLf If Request("full") = "true" Then Response.Write "  " & objChild.selectSingleNode("description").text & " " & VbCrLF Next 'Clean up after yourself Set objRoot = Nothing set objChannel = Nothing set objLinks = Nothing set objChild = Nothing End If Response.Write "

" & VbCrLf If Not i = UBound(arrFeeds,2) Then Response.Write "
" & VbCrLf Response.Flush 'Dump the buffer to the browser Next 'Do it all again! set xmlObj = nothing %>