Obtendo meta tags,title,Keywords,Description

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
' ------------------------------------------------------------------------------
%>