Spider Object

Spider Object:

The Spider Object returns the head, title, meta-tags, body and address data of a web page. The Spider object is used to parse a web page. By calling the various methods of the Spider object, you can effectively read and save parts of a web page for further reference.

Methods:

object.Retrieve( http_address )
Retrieve gathers a web page's source code and stores it into memory. This method must be called before any other methods or read only properties of the class are called.

object.PageAddress()
Returns a web page's complete path, starting with http://

object.PageTitle()
Returns a web page's full HTML title.

object.RawHeader()
Returns everything between the <HEAD> tags.

object.RawBody()
Returns everything between the <BODY> tags.

object.RawMetaTags()
Returns an array of each <META> tag.

object.MetaTagPairs()
Returns a two-dimensional array of HTML meta-tag names and values.

Syntax:

Set object = New Spider

Example Usage:

<%
Dim Robot, item, i, a

 ' create an instance of the spider class
Set Robot = New Spider

 ' get a web page to parse
Robot.Retrieve( "http://www.ci.nyc.ny.us/" )

 ' show the URL
Response.Write Robot.PageAddress() & "<HR>"

 ' show the title
Response.Write Robot.PageTitle() & "<HR>"

 ' show the entire header
Response.Write Server.HTMLEncode( Robot.RawHeader() ) & "<HR>"

 ' show the entire body
Response.Write Server.HTMLEncode( Robot.RawBody() ) & "<HR>"

 ' show each meta-tag
For Each Item In Robot.RawMetaTags()
	Response.Write Server.HTMLEncode( Item ) & "<BR>"
Next
Response.Write "<HR>"

 ' show meta-tag names and values
a = Robot.MetaTagPairs()
For i = 0 to UBound( a, 2 )
	 ' meta tag name
	Response.Write "<B>" & a( 0, i ) & "</B><BR>"
	 ' meta tag value
	Response.Write a( 1, i ) & "<BR><BR>"
Next

 ' free spider class instance
Set Robot = Nothing
%>

ASP Source Code:

<%
Class Spider
	Private gblTxt, gblTmp, strPath, bMinimal

	Private Sub Class_Initialize()
		gblTmp   = ""
		gblTxt   = ""
		strPath  = ""
		bMinimal = False
	End Sub

	Private Sub Class_Terminate()
		gblTmp	= ""
		gblTxt  = ""
		strPath = ""
	End Sub

	Private Function GetWebPage(byVal address)
		Dim Fetch
		On Error Resume Next
		Set Fetch  = GetObject("java:HTTPFetch")
		If Err Then
			Err.Clear
			GetWebPage = Null
			Exit Function
		End If
		On Error GoTo 0
		GetWebPage = UCase( Trim( Fetch.GetURL(address) ) )
		Set Fetch  = Nothing
	End Function

	Private Function SrchNDisplay(byVal EraseSrchCriteria, byval intInc, _
				      byVal Criteria1, byVal Criteria2)
		Dim strSt, tmp
		Select Case CBool( EraseSrchCriteria )
			Case True
				strSt =	InStr( gbltxt, Criteria1 ) + intInc
				tmp =	Mid( gbltxt, strSt, InStr( _
					strSt, gbltxt, Criteria2 ) _
					- strSt )
			Case False
				strSt =	InStr( gbltxt, Criteria1 )
				tmp =	Mid( gbltxt, strSt, InStr( _
					strSt, gbltxt, Criteria2 ) _
					- strSt  + intInc)
		End Select
		SrchNDisplay = tmp
	End Function

	Private Sub RdMeta(byval lngStart, byval strHeaderTxt)
		dim secStart, strTmp
		On Error Resume Next
		lngStart = InStr( lngStart, strHeaderTxt, "<META " )
		secStart = InStr( lngStart + 5, strHeaderTxt, ">"  )
		if lngStart = 0 then RdMeta = "" : Exit Sub
		strTmp = Mid( strHeaderTxt, lngStart , _
			 secStart - lngStart + 1) & vbCrLf
		If Err Then Exit Sub
		On Error GoTo 0
		gblTmp = gblTmp & strTmp & "/|\"
		Call RdMeta( secStart, strHeaderTxt )
	End Sub

	Private Function FixTag(byVal indTag)
		dim strInc
		strInc = Mid( indTag, InStr( indTag, chr(34) ) + 1 )
		if len( strInc ) > 0 then _
			strInc = Left( strInc, Len( strInc ) - 1 )
		FixTag = Replace( strInc, chr(34), "" )
	End Function

	Private Function GetTagName(byVal dirtytag)
		dim a, b
		On Error Resume Next
		if instr( dirtytag, chr(34) ) then
			a = inStr( dirtytag, "NAME=" & chr(34) )
			b = instr( a + 6, dirtytag, chr(34) & " " )
			if a = 0 then
				a = inStr( dirtytag, "NAME = " & chr(34) )
			end if
		else
			 ' if no "'s are found
			a = inStr( dirtytag, "NAME=" )
			b = instr( a + 5, dirtytag, " " )
		end if
		GetTagName = Mid( dirtytag, a, b - a + 1 )
		If Err Then
			if instr( dirtytag, chr(34) ) then
				a = inStr( dirtytag, "EQUIV=" & chr(34) )
				b = instr( a + 7, dirtytag, chr(34) & " " )
				if a = 0 then
					a = inStr( dirtytag, "EQUIV = " & chr(34) )
				end if
			else
				 ' if no "'s are found
				a = inStr( dirtytag, "EQUIV=" )
				b = instr( a + 6, dirtytag, " " )
			end if
		Else
			Exit Function
		End If
		GetTagName = ""
		GetTagName = Mid( dirtytag, a, b - a + 1 )
		On Error GoTo 0
	End Function

	Private Function GetTagValue(byVal dirtytag)
		dim a, b
		dirtytag = UCASE( dirtytag )
		if instr( dirtytag, chr(34) ) then
			a = inStr( dirtytag, "CONTENT=" & chr(34) )
			b = instr( a + 9, dirtytag, chr(34) & ">" )
			if a = 0 then
				a = inStr( dirtytag, "CONTENT = " & chr(34) )
				b = instr( a + 9, dirtytag, chr(34) & ">" )
			end if
		elseif instr( dirtytag, chr(39) ) then
			a = inStr( dirtytag, "CONTENT=" & chr(39) )
			b = instr( a + 9, dirtytag, chr(39) & ">" )
		end if
		if b = 0 then
			GetTagValue = Mid( dirtytag, a )
		elseif a = 0 then
			GetTagValue = Mid( dirtytag, 1, b )
		else
			GetTagValue = Mid( dirtytag, a, b - a + 1 )
		end if
	End Function

	Public Default Sub Retrieve(byval HTTPpath)
		bMinimal = True
		strPath = HTTPpath
		gblTxt = Trim( UCase( GetWebPage( HTTPpath ) ) )
		If IsNull( gblTxt ) Then
			Err.Raise 5175, "Spider Class", _
				  "Web Page Cannot Be Retrieved."
		End If
	End Sub

	Public Function PageTitle()
		If NOT bMinimal Then RetrieveError()
		PageTitle = Trim( SrchNDisplay(True, 7, _
			    "<TITLE>", "</TITLE>") )
	End Function

	Public Function RawHeader()
		If NOT bMinimal Then RetrieveError()
		RawHeader = Trim( SrchNDisplay(False, 7, _
			    "<HEAD>", "</HEAD>") )
	End Function

	Public Function RawBody()
		If NOT bMinimal Then RetrieveError()
		RawBody = Trim( SrchNDisplay(False, 7, _
			  "<BODY", "</BODY>") )
	End Function

	Public Function RawMetaTags()
		If NOT bMinimal Then RetrieveError()
		Dim strTmp, max, i
		Call RdMeta( 1, RawHeader )
		strTmp = Split( gblTmp, "/|\" )
		max = ubound(strTmp) - 1
		Redim Preserve strTmp(max)
		for i = 0 to ubound(strTmp)
			strTmp(i) = Trim( Replace( Replace( _
				strTmp(i), vbCrLf, ""), vbTab, "" ) )
		next
		RawMetaTags = strTmp
	End Function

	Public Property GET PageAddress()
		If NOT bMinimal Then RetrieveError()
		PageAddress = Trim( UCase( strPath ) )
	End Property

	Public Function MetaTagPairs()
		If NOT bMinimal Then RetrieveError()
		Dim tmp, item, dic, a, b, i
		Dim outarray()
		tmp = RawMetaTags
		Set dic = CreateObject("scripting.dictionary")	
		on error resume next
		for each item in tmp
			dic.add FixTag( GetTagName( item ) ), _
				FixTag( GetTagValue( item ) ) 
		next
		on error goto 0
		a = dic.keys
		b = dic.items
		Redim outarray( 1, dic.count - 1 )
		for i = 0 to dic.count - 1
			outarray(0, i) = a(i)
			outarray(1, i) = b(i)
		next
		set dic = Nothing
		MetaTagPairs = outarray
	End Function

	Private Sub RetrieveError()
		Err.Raise 5175, "Spider Class", "Function Error. " & _
				"You cannot call any method or read " & _
				"only property of the Spider Class " & _
				"before calling the Retrieve Method."
	End Sub
End Class
%>
See it Work