Obtendo meta tags,title,Keywords,Description

[xanburzum 169]

Este script irá solicitar a página do servidor especificado no URL e analisar o título, descrição e palavras-chave para você,tem capacidade para obter um documento de outro site e analisar dados meta ,tais como o título, descrição e palavras-chave.

 

<!--#INCLUDE FILE="clsHTMLParser.asp"-->
<%
Dim StrURL
Dim StrHTML
Dim ObjParser

StrURL = Request.QueryString("URL")
%>
<H1></H1>
<P>

Este script irá solicitar a página do servidor especificado no URL e analisar o título, descrição e palavras-chave para você
</P>
<FORM>
	<INPUT size="50" name="URL" value="<%=StrURL%>"><BR>
	<INPUT type="Submit" value="Parse">
</FORM>
<BR><BR>
<%
If Not StrURL = "" Then
	Set ObjParser = New clsHTMLParser
	With ObjParser
		StrHTML = .GetURL(StrURL)
		%>
		<TABLE border="1">
			<TR>
				<TD>Title</TD>
				<TD><%=.Title%></TD>
			</TR>
			<TR>
				<TD>Keywords</TD>
				<TD><%=.Keywords%></TD>
			</TR>
			<TR>
				<TD>Description</TD>
				<TD><%=.Description%></TD>
			</TR>
		</TABLE>
		<HR>
		<%
		Response.Write Replace(Server.HTMLEncode(StrHTML), vbCrLf, "<BR>")
	End With
	Set ObjParser = Nothing
End If
%>

clsHTMLParser.asp

<%
' HTML Parser
' ------------------------------------------------------------------------------
Class clsHTMLParser
' ------------------------------------------------------------------------------
	Private mStrHTML
	Private mObjRegExp
	Private mObjMatches
	Private mObjMatch
	Public Title
	Public Keywords
	Public Description
' ------------------------------------------------------------------------------
	Public Property Let HTML(ByRef pStrHTML)
		mStrHTML = pStrHTML

		Set mObjRegExp = New RegExp
		mObjRegExp.IgnoreCase = True

		Call ParseTitle()
		Call ParseDescription()
		Call ParseKeywords()

		Set mObjMatch = Nothing
		Set mObjMatches = Nothing
		Set mObjRegExp = Nothing

	End Property
' ------------------------------------------------------------------------------
	Public Property Get HTML()
		HTML = mStrHTML
	End Property
' ------------------------------------------------------------------------------
	Private Sub ParseTitle()
		Title = ""
		mObjRegExp.Pattern = "<TITLE>([^<]*)</TITLE>"
		Set mObjMatches = mObjRegExp.Execute(mStrHTML)
		If mObjMatches.Count = 0 Then Exit Sub
		Title = mObjMatches.item(0).Value
		Title = Replace(Title, "<TITLE>", "", 1, -1, vbTextCompare)
		Title = Replace(Title, "</TITLE>", "", 1, -1, vbTextCompare)
	End Sub
' ------------------------------------------------------------------------------
	Private Sub ParseDescription()
		Description = ""
		mObjRegExp.Pattern = "<META[^>]+(name=""description""|content=""([^""]*)"")[^>]+(name=""description""|content=""([^""]*)"")[^>]*>"
		Set mObjMatches = mObjRegExp.Execute(mStrHTML)
		If mObjMatches.Count = 0 Then Exit Sub
		Description = mObjMatches.item(0).Value
		Description = Mid(Description, InStr(1, Description, "content=""", vbTextCompare) + 9)
		Description = Mid(Description, 1, InStr(1, Description, """", vbTextCompare) -1)
	End Sub
' ------------------------------------------------------------------------------
	Private Sub ParseKeywords()
		Keywords = ""
		mObjRegExp.Pattern = "<META[^>]+(name=""keywords""|content=""([^""]*)"")[^>]+(name=""keywords""|content=""([^""]*)"")[^>]*>"
		Set mObjMatches = mObjRegExp.Execute(mStrHTML)
		If mObjMatches.Count = 0 Then Exit Sub
		Keywords = mObjMatches.item(0).Value
		Keywords = Mid(Keywords, InStr(1, Keywords, "content=""", vbTextCompare) + 9)
		Keywords = Mid(Keywords, 1, InStr(1, Keywords, """", vbTextCompare) -1)
	End Sub
' ------------------------------------------------------------------------------
	Public Function GetURL(ByRef pStrURL)

		Dim lObjSpider
		Dim strText

		If pStrURL = "" Then Exit Function

		On Error Resume Next

		' Different variations of XML objects
		'Set lObjSpider = Server.CreateObject ("MSXML2.XMLHTTP.3.0")
		'Set lObjSpider = Server.CreateObject ("MSXML2.ServerXMLHTTP")
		Set lObjSpider = Server.CreateObject ("Microsoft.XMLHTTP")
		

		' Could not create Internet Control
		If Err Then
			GetURL = "Error: " & Err.Description
			Exit Function
		End If
		
		On Error Goto 0

		With lObjSpider
			.Open "GET", pStrURL, False, "", ""
			.Send
			GetURL = .ResponseText
		End With
		Set LobjSpider = Nothing

		HTML = GetURL
		
	End Function
' ------------------------------------------------------------------------------
End Class
' ------------------------------------------------------------------------------
%>

[Patrique 0]

How... muito bom script! va ser bem util!

 

Valew

 

[]'s