A relatively simple Alexa thief program. Friends who like this function can learn its principles. I believe you will be able to write this program soon<%
'In order to support originality, please keep this comment, thank you!
'Author: Fei Caoshang
'Get the main domain name
Function getDomainUrl(url)
tempurl=replace(url,http://,)
if instr(tempurl,/)>0 then
tempurl=left(tempurl,instr(tempurl,/)-1)
endIf
getDomainurl=tempurl
End Function
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl=$False$ Then
GetHttpPage=$False$
Exit Function
End If
Dim Http
Set Http=server.createobject(MSXML2.XMLHTTP)
Http.open GET,HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Set Http=Nothing
GetHttpPage=$False$
Exit function
End if
GetHTTPage=Http.responseText
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
'================================================== =
'Function name: ScriptHtml
'Function: filter html tags
'Parameter: ConStr ------ The string to be filtered
'TagName ------The tag to be filtered
' FType 1 means filtering the left label, 2 means filtering the left and right labels and the middle value 3 means filtering the left label and right label, retaining the content.
'================================================== =
Function ScriptHtml(Byval ConStr,TagName,FType,includestr)
Dim Re
Set Re=new RegExp
Re.IgnoreCase=true
Re.Global=True
Select Case FType
Case 1
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>
ConStr=Re.Replace(ConStr,)
Case 2
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>.*?</ & TagName & ([^>])*>
'response.write constr&<br>
ConStr=Re.Replace(ConStr,)
'response.write server.htmlencode(constr)&<br>
Case 3
Re.Pattern=< & TagName & ([^>])*(&includestr&){1,}([^>])*>
ConStr=Re.Replace(ConStr,)
Re.Pattern=</ & TagName & ([^>])*>
ConStr=Re.Replace(ConStr,)
End Select
ScriptHtml=ConStr
Set Re=Nothing
End Function
'================================================== =
'Function name: GetBody
'Function: intercept string
'Parameter: ConStr ------The string to be intercepted
'Parameter: StartStr ------start string
'Parameter: OverStr ------End string
'Parameter: IncluL ------Whether StartStr is included
'Parameter:IncluR ------whether to include OverStr
'================================================== =
Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr=$False$ or ConStr= or IsNull(ConStr)=True Or StartStr= or IsNull(StartStr)=True Or OverStr= or IsNull(OverStr)=True Then
GetBody=$False$
Exit Function
End If
DimConStrTemp
Dim Start,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
'response.write Start&<br>&IncluL&<br>
'response.end
If Start<=0 then
GetBody=$False$
Exit Function
Else
If IncluL=False Then
Start=Start+LenB(StartStr)
End If
End If
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
'response.write Over
'response.end
'response.write Start& &Over& &Over-Start
'response.end
If Over<=0 Or Over<=Start then
GetBody=$False$
Exit Function
Else
If InclR=True Then
Over=Over+LenB(OverStr)
End If
End If
GetBody=MidB(ConStr,Start,Over-Start)
'response.write getBody
'response.end
End Function
'================================================== =
'Function name: GetArray
'Function: Extract the link address, separated by $Array$
'Parameter: ConStr ------Extract the original characters of the address
'Parameter: StartStr ------start string
'Parameter: OverStr ------End string
'Parameter: IncluL ------Whether StartStr is included
'Parameter:IncluR ------whether to include OverStr
'================================================== =
Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If ConStr=$False$ or ConStr= Or IsNull(ConStr)=True or StartStr= Or OverStr= or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
GetArray=$False$
Exit Function
End If
Dim TempStr,TempStr2,objRegExp,Matches,Match
TempStr=
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = (&StartStr&).+?(&OverStr&)
Set Matches =objRegExp.Execute(ConStr)
For Each Match in Matches
TempStr=TempStr & $Array$ & Match.Value
Next
Set Matches=nothing
If TempStr= Then
GetArray=$False$
Exit Function
End If
TempStr=Right(TempStr,Len(TempStr)-7)
If IncluL=False then
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,)
End if
If InclR=False then
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,)
End if
Set objRegExp=nothing
Set Matches=nothing
If TempStr= then
GetArray=$False$
Else
GetArray=TempStr
End if
End Function
Function getAlexaRank(weburl)
tempurl=getDomainUrl(weburl)
'Read the data in http://client.alexa.com/common/css/scramble.css
alexacss=http://client.alexa.com/common/css/scramble.css
strAlexaCss=GetHttpPage(alexacss)
'response.write strAlexaCss
'response.end
alexarankqueryurl=http://www.alexa.com/data/details/traffic_details/&tempurl
strAlexaContent=GetHttpPage(alexarankqueryurl)
rankcontent=getBody(strAlexaContent,Information Service.-->,<!-- google_ad_section_end(name=default) -->,false,false)
'Get the span class
strspan=GetArray(rankcontent,<span class=,,false,false)
'response.write rankcontent&<br>
'response.write strspan&<br>
'response.end
If strspan<>$False$ Then
aspan=split(strspan,$Array$)
For i=0 To UBound(aspan)
'response.write .&aspan(i)
'Determine whether aspan(i), the span's class, exists in alexacss. If it exists, you need to remove the span and the data in the span.
If InStr(strAlexaCss,.&aspan(i))>=1 Then
'response.write aspan(i)&<br>
'response.end
'Indicates that the attribute is none and needs to be replaced.
rankcontent=ScriptHtml(rankcontent,span,2,aspan(i))
Else
rankcontent=ScriptHtml(rankcontent,span,1,aspan(i))
End if
Next
'Replace the span tag on the right that was removed above.
rankcontent=Replace(rankcontent,</span>,)
End If
If rankcontent=$False$ Then
rankcontent=No Data
End if
getAlexaRank=Replace(rankcontent,,,)
End Function
url=request.querystring(url)
%>
<form name=alexaform method=get>
Input URL:<input type= name=url value=<%=url%> size=40> <input type=submit value=query>
</form>
<%
If url<> Then
response.write Your website’s ALEXA ranking is:
response.flush
rank=getAlexaRank(url)
response.write rank
End if
%>