Ir para conteúdo

POWERED BY:

Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

xanburzum

Tag Cloud

Por , em ASP Clássico

Recommended Posts

xanburzum    169

xanburzum
Postado

Há algumas boas razões para tag Cloud tornaram-se tão popular na web. Eles são realmente úteis.

 

Este script cria um tag baseado em um único arquivo RSS. Ela vai contar todas as palavras presentes no elemento "título".Ele lê o arquivo do disco, a expressão é executadA através de um simples algoritmo e, em seguida, exibe a expressão mais comum encontrado em negrito.

 

<% @Language="VBScript" %>
<%
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

%>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<title>TagCloud</title>
<style type="text/css">
#tagCloud {font-family: verdana; width: 300px; border: 1px solid gray; padding: 5px 0px 5px 0px; text-align: center; font-weight: bold;}
.tag1 {font-size: 12px;}
.tag2 {font-size: 18px;}
.tag3 {font-size: 24px;}
</style>
</head>
<body>
<h3>TAG CLOUD:</h3>
<%

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

'// LE o arquivo RSS e remove alguns CARACTERES comuns 
m_sTags = Replace(Replace(Replace(Replace(Replace(Replace(ReadRSSTags, "?", ""), "!", ""), ".", ""), ",", ""), "-", ""), ":", "")

m_sSmallWords = " Teste seus conhecimentos sobre o Windows 7 participando do desafio WIN THE 7 e concorra a consoles Xbox 360 e a entradas para o Tech-Ed Brasil 2009."

'// ARMAZENE AS PALAVRAS (tags) em uma matriz
m_aTags = Split(m_sTags, " ")
m_iWordCount = 1
m_bMatch = False

'// PALAVRAS alfabeticamente EM ORDEM . Isto torna-os mais fáceis de contar
Call BubbleSort(m_aTags)

m_sHTML = "<div id=""tagCloud"" title=""Hot tópicos"">"

iMax = UBound(m_aTags)

'// LOOP 
	For i = 0 To iMax
		m_sCurrent = m_aTags(i)
		
		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

						If m_iWordCount = 2 Then m_sHTML = m_sHTML & "<span class=""tag1"">" & m_sLast & "</span> "
						If m_iWordCount = 3 Then m_sHTML = m_sHTML & "<span class=""tag2"">" & m_sLast & "</span> "
						If m_iWordCount > 3 Then m_sHTML = m_sHTML & "<span class=""tag3"">" & m_sLast & "</span> "

					End If
				End If
			End If

			m_iWordCount = 1
		End If
		
		m_sLast = m_sCurrent
	Next

'// OUTPUT TAG CLOUD
Response.Write m_sHTML & "</div></body></html>"

'------------------------------------------------------------------------------------------------------------
' Carregar arquivo RSS a partir do disco.
'------------------------------------------------------------------------------------------------------------
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


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

%>

Compartilhar este post

Link para o post
Compartilhar em outros sites

xanburzum    169

xanburzum
Postado

valeu ASPmano Ted´k

e melhorando posta pra noisssz , ae..

Compartilhar este post

Link para o post
Compartilhar em outros sites
Ir para a lista de tópicos ASP Clássico
×

Informação importante

Ao usar o fórum, você concorda com nossos Termos e condições.

  Aceito