Display the Most Recent Code From FreeVBCode.com on your Web Site

Category:

ASP, HTML and XML

Type:

Snippets

Difficulty:

Intermediate

Author: Intelligent Solutions Inc.

Version Compatibility: ASP

More information:

This is an adaptation of the code at http://www.freevbcode.com/ShowCode.Asp?ID=5665, which demonstrates how to display data from an RSS feed. This example uses that code to display the newest code from FreeVBCode.com, which is now syndicated in an RSS feed. If you are going to use this code on your site, please use one of the demonstrated caching mechanisms (file or application variable) so a connection is not made to FreeVBCode.com on every request.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

<%
bUseApp = false 'set to true if you
'want to cache responses in memory
'(Application variable) rather than
'file. 
DisplayRSSFeed "http://www.freevbcode.com/rss_newcode.asp", "Latest Code From FreeVBCode.com"
function ReplaceMultiple(InputString, CharsToReplace)
iCount = len(CharsToReplace)
sTemp = InputString
for iCtr = 1 to iCount
   sChar = mid(CharsToReplace, iCtr, 1)

sTemp = replace(sTemp, sChar, "")

Next
ReplaceMultiple = sTemp
End Function
function WriteToFile(FileName, Contents)

iMode = 2 'overwrite
set oFs = server.createobject("Scripting.FileSystemObject")
set oTextFile = oFs.OpenTextFile(FileName, 2, True)
oTextFile.Write Contents
oTextFile.Close
set oTextFile = nothing
set oFS = nothing

end function

Private Function ReadTextFile(fName)
 set oFs = server.createobject("Scripting.FileSystemObject")
      If oFs.FileExists(fName) Then
     Set FSTR = ofs.OpenTextFile(fName)
     ReadTextFile = FSTR.ReadAll
     FSTR.Close
     Set FSTR = Nothing
      Set FSO = Nothing
end if
End Function

Private Function ReadAppVariable(fName)

ReadAppVariable = Application(fName)

End Function
Private Function WriteAppVariable(FileName, Contents, RSSURL)

Application.lock
Application(FileName) = contents
Application(RSSURL) = Hour(now)
Application.unlock
end function

Function DisplayRSSFeed(RSSURL, FeedName)
'caches the feed, updates every hour, uses a file cache
'if it hasn't been update in an hour or running for the first time
'get it and save from file,
'else read it from file

Set objXML = Server.CreateObject("MSXML2.DOMDocument")
   objXML.async = False
'necessary because MSXML
'doesn't seem to work very well
'when an external DTD is referred to
 objXML.validateOnParse = false
 objXML.resolveExternals = false

iPos = InstrRev(RSSURL, "/")
if iPos = 0 then
		 sFileName = RSSURL
else
		 sFileName = mid(RSSURL, iPos + 1)
end if

sFileName = FeedName &  "_" & sFileName & ".xml"
		 'remove invalid/unwanted chars
		 sFileName = ReplaceMultiple(sFileName,"[]/\\(^+)$,)?&:=")
		 sFileName = Server.MapPath(".") & "\" & sFileName

if Application(RSSURL) <> Hour(Now) then

set objXMLHTTP = Server.CreateObject("MSXML2.SERVERXMLHTTP")

objXMLHTTP.Open "GET", RSSURL, false

objXMLHTTP.SetRequestHeader "Content-type", "text/html"
on error resume next
 objXMLHTTP.Send

sAns = objXMLHTTP.ResponseText
on error goto 0

set objXMLHTTP = nothing

'Ensure you have a valid XML response

bAns = objXML.loadXML(sAns)
		 if bAns = true then

'save to file
		 'Requires ASP user has write permissions to'
		 'path you use
	if bUseApp = false then
	 	WriteToFile sFileName, sAns
		Application.Lock
 		'refresh in an hour
		Application(RSSURL) = Hour(now)
 		Application.unlock
	else
		WriteAppVariable sFileName, sAns, RSSURL
	end if
		
 	
	else 'if invalid, try using a previous version
		'response.write "Loading from file " & sFileName & " due to failure"
		if bUseApp = false then
		sContents = ReadTextFile(sFileName)
		else
		sContents = ReadAppVariable(sFileName)
		end if

bAns = objXML.loadXML(sContents)
		'bAns = objXML.load(sFileName)
	end if
else 'try to load from cache on failure to refresh
		 if bUseApp= false then
			sContents = ReadTextFile(sFileName)
		else
			sContents = ReadAppVariable(sFileName)
		end if

bAns = objXML.loadXML(sContents)

End if

if bAns then

set objItemNodes = _
   objXML.DocumentElement.SelectSingleNode("channel").SelectNodes("item")

'display as table

response.write "<p align=center><b>" & FeedName & "</b></p>"
response.write "<table cellspacing=5 width='100%'>"
response.write "<TR><TD><B>Title</b></td>"
response.write "<TD><B>Date Added</b></td>"
response.write "</tr>"
response.write "<TR><TD> </td></tr>"
for each oNode in objItemNodes

sLink = oNode.selectSingleNode("link").Text
set oDescriptionNode = oNode.selectSingleNode("description")
			if not oDescriptionNode is nothing then
			sDesc= oDescriptionNode.Text
			else
			sDesc = ""
			end if
				 sTitle = oNode.selectSingleNode("title").Text
	 response.write "<TR><TD valign=Top><A HREF ='" & sLink & "'>" & sTitle & _
              "</a></td>"
	response.write "<TD valign=top width='60%'>" & sDesc & "</td>"

next
response.write "</table>"

else

response.write "The requested feed is not available"

end if
set oNode = Nothing
set objItemNodes = Nothing
set objXML = Nothing
End function