<% 
'為了支持原創(chuàng)，請保留該處注釋，謝謝！ 
'作者：草上飛 
'獲取主域名 
Function getDomainUrl(url) 
tempurl=replace(url,"http://","") 
if instr(tempurl,"/")>0 then 
tempurl=left(tempurl,instr(tempurl,"/")-1) 
end If 
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 
GetHTTPPage=Http.responseText 
Set Http=Nothing 
If Err.number<>0 then 
Err.Clear 
End If 
End Function 

'================================================== 
'函數(shù)名：ScriptHtml 
'作 用：過濾html標記 
'參 數(shù)：ConStr ------ 要過濾的字符串 
' TagName ------要過濾的標簽 
' FType 1表示過濾左邊標簽 2表示過濾左右標簽及中間的值 3表示過濾左邊標簽和右邊標簽，保留內容。 
'================================================== 
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 

'================================================== 
'函數(shù)名：GetBody 
'作 用：截取字符串 
'參 數(shù)：ConStr ------將要截取的字符串 
'參 數(shù)：StartStr ------開始字符串 
'參 數(shù)：OverStr ------結束字符串 
'參 數(shù)：IncluL ------是否包含StartStr 
'參 數(shù)：IncluR ------是否包含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 
Dim ConStrTemp 
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 IncluR=True Then 
Over=Over+LenB(OverStr) 
End If 
End If 

GetBody=MidB(ConStr,Start,Over-Start) 
'response.write getBody 
'response.end 
End Function 

'================================================== 
'函數(shù)名：GetArray 
'作 用：提取鏈接地址，以$Array$分隔 
'參 數(shù)：ConStr ------提取地址的原字符 
'參 數(shù)：StartStr ------開始字符串 
'參 數(shù)：OverStr ------結束字符串 
'參 數(shù)：IncluL ------是否包含StartStr 
'參 數(shù)：IncluR ------是否包含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 IncluR=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) 
'讀取http://client.alexa.com/common/css/scramble.css中的數(shù)據(jù) 
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) 
'獲取其中的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) 
'判定aspan(i)即span的class是否在alexacss中存在，如果存在，則需要將這個span和span中的數(shù)據(jù)去掉。 
If InStr(strAlexaCss,"."&aspan(i))>=1 Then 
'response.write aspan(i)&"<br>" 
'response.end 
'表示屬性為none.需要替換掉。 
rankcontent=ScriptHtml(rankcontent,"span",2,aspan(i)) 
Else 
rankcontent=ScriptHtml(rankcontent,"span",1,aspan(i)) 
End if 
Next 
'替換上面少去掉的右邊的span標簽。 
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> 
輸入網(wǎng)址:<input type="" name="url" value="<%=url%>" size=40> <input type="submit" value="查 詢">
</form> 
<% 
If url<>"" Then 

response.write "您的網(wǎng)站在ALEXA的排名為：" 
response.flush 
rank=getAlexaRank(url) 
response.write rank 
End if 
%>