<%
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
'==================================================
'函数名：ScriptHtml
'作 用：过滤html标记
'参 数：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,}([^>])*>.*?])*>"
'response.write constr&"
"
ConStr=Re.Replace(ConStr,"")
'response.write server.htmlencode(constr)&"
"
Case 3
Re.Pattern="<" & TagName & "([^>])*("&includestr&"){1,}([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="])*>"
ConStr=Re.Replace(ConStr,"")
End Select
ScriptHtml=ConStr
Set Re=Nothing
End Function
'==================================================
'函数名：GetBody
'作 用：截取字符串
'参 数：ConStr ------将要截取的字符串
'参 数：StartStr ------开始字符串
'参 数：OverStr ------结束字符串
'参 数：IncluL ------是否包含StartStr
'参 数：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&"
"&IncluL&"
"
'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
'==================================================
'函数名：GetArray
'作 用：提取链接地址，以$Array$分隔
'参 数：ConStr ------提取地址的原字符
'参 数：StartStr ------开始字符串
'参 数：OverStr ------结束字符串
'参 数：IncluL ------是否包含StartStr
'参 数：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中的数据
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.-->","",false,false)
'获取其中的span的class
strspan=GetArray(rankcontent,""
'response.write strspan&"
"
'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中的数据去掉。
If InStr(strAlexaCss,"."&aspan(i))>=1 Then
'response.write aspan(i)&"
"
'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,"","")
End If
If rankcontent="$False$" Then
rankcontent="No Data"
End if
getAlexaRank=Replace(rankcontent,",","")
End Function
url=request.querystring("url")
%>
您的网站的国际排名是：<%
If url<>"" Then
response.flush '好好看看这句话的意思
rank=getAlexaRank(url)
response.write rank
End if
%>
本站的alexa排名查询会不断的丰富 |
Alexa 排名是目前常引用的用来评价某一网站访问量的一个指标。事实上，Alexa 排名是根据对用户下载并安装了 Alexa Tools Bar
嵌入到 IE
等浏览器，从而监控其访问的网站数据进行统计的，因此，其排名数据并不具有绝对的权威性。但由于其提供了包括综合排名、到访量排名、页面访问量排名等多个评价指标信息，且目前尚没有而且也很难有更科学、合理的评价参考，大多数人还是把它当作当前较为权威的网站访问量评价指标。
本站查询的数据经
amazon 授权，采集自 amazon 与 Alexa 合作提供的官方 XML 数据，并进行适当加工排版后形成。由于其内部服务器间同步时差等原因，或许与
Alexa 网站显示的数据略有差别，但不影响对整体的判断，甚至提供了比 Alexa
官方网站显示更多的数据。 |
