TagCloud

<% @Language="VBScript" %> <% '============================================================ ' APP: TagCloud ' AUTHOR: © www.u229.no ' CREATED: October 2006 '============================================================ ' ROUTINES: ' - Function ReadRSSTags() ' - Sub BubbleSort(byRef a) '============================================================ Option Explicit On Error Resume Next With Response .ExpiresAbsolute = #1/1/1980# .AddHeader "cache-control", "no-cache, must-revalidate" .AddHeader "pragma", "no-cache" .AddHeader "Content-Type", "text/html; charset=UTF-8" End With %> TagCloud

TAG CLOUD MADE FROM A BBC FEED:

<% Dim m_sTags Dim m_aTags Dim m_sSmallWords Dim m_sCurrent, m_sLast Dim m_bMatch Dim m_iWordCount Dim m_sHTML Dim i, iMax '// READ THE RSS FILE AND REMOVE SOME COMMON CHARACTERS m_sTags = Replace(Replace(Replace(Replace(Replace(Replace(ReadRSSTags, "?", ""), "!", ""), ".", ""), ",", ""), "-", ""), ":", "") '// THESE ARE THE SMALL WORDS THAT WE DON'T CARE ABOUT. INCLUDE MORE WORDS IF YOU LIKE. m_sSmallWords = " in a an and or but for to it that this those these all on off can will no not we will be more new up down over you they get one two three four five six seven eight nine ten nobody now back after yes no like " '// STORE THE WORDS (TAGS) IN AN ARRAY m_aTags = Split(m_sTags, " ") m_iWordCount = 1 m_bMatch = False '// SORT THE WORDS ALPHABETICALLY. THIS MAKES THEM EASIER TO COUNT. Call BubbleSort(m_aTags) m_sHTML = "

" iMax = UBound(m_aTags) '// LOOP THE WORDS For i = 0 To iMax m_sCurrent = m_aTags(i) '// WE FOUND A MATCH! If m_sCurrent = m_sLast Then m_bMatch = True m_iWordCount = (m_iWordCount + 1) Else If m_bMatch Then If m_iWordCount > 1 Then If Not InStr(m_sSmallWords, LCase(m_sLast)) > 0 Then '// THIS IS OUR SIMPLE WEIGHING ALGORITHM: WE DON'T CARE ABOUT WORDS APPEARING JUST ONE TIME. If m_iWordCount = 2 Then m_sHTML = m_sHTML & "" & m_sLast & " " If m_iWordCount = 3 Then m_sHTML = m_sHTML & "" & m_sLast & " " If m_iWordCount > 3 Then m_sHTML = m_sHTML & "" & m_sLast & " " End If End If End If m_iWordCount = 1 End If m_sLast = m_sCurrent Next '// OUTPUT THE TAG CLOUD Response.Write m_sHTML & "

" '------------------------------------------------------------------------------------------------------------ ' Comment: Load RSS file from disk. '------------------------------------------------------------------------------------------------------------ Function ReadRSSTags() On Error Resume Next Dim oXML, oNode, oNodeList, sRetVal Set oXML = CreateObject("MSXML2.DOMDocument.6.0") If Err Then On Error Resume Next Set oXML = CreateObject("MSXML2.DOMDocument.3.0") End If With oXML .async = False If Not .Load(Server.MapPath("bbc.xml")) Then Set oXML = Nothing: Exit Function End With Set oNodeList = oXML.selectNodes("//item") If oNodeList.length > 0 Then For Each oNode In oNodeList sRetVal = sRetVal & oNode.selectSingleNode("title").Text & Chr(32) Next End If Set oNodeList = Nothing Set oXML = Nothing ReadRSSTags = sRetVal End Function '------------------------------------------------------------------------------------------------------------ ' Comment: Sort the tags. http://www.4guysfromrolla.com/demos/bubblesort.asp '------------------------------------------------------------------------------------------------------------ Sub BubbleSort(ByRef a) On Error Resume Next Dim i, j, iMax Dim Start, iNew, swap iMax = UBound(a) For i = 0 To iMax - 1 Start = a(i) iNew = a(i) swap = i For j = i + 1 To iMax If a(j) < iNew Then swap = j iNew = a(j) End If Next If swap <> i Then a(swap) = Start a(i) = iNew End If Next End Sub %>