<%
'为了支持原创，请保留该处注释，谢谢！
'作者：草上飞
'获取主域名
FunctiongetDomainUrl(url)
tempurl=replace(url,"http://","")
ifinstr(tempurl,"/")>0then
tempurl=left(tempurl,instr(tempurl,"/")-1)
endIf
getDomainurl=tempurl
EndFunction
FunctionGetHttpPage(HttpUrl)
IfIsNull(HttpUrl)=TrueOrLen(HttpUrl)<18OrHttpUrl="$False$"Then
GetHttpPage="$False$"
ExitFunction
EndIf
DimHttp
SetHttp=server.createobject("MSXML2.XMLHTTP")
Http.open"GET",HttpUrl,False
Http.Send()
IfHttp.Readystate<>4then
SetHttp=Nothing
GetHttpPage="$False$"
Exitfunction
Endif
GetHTTPPage=Http.responseText
SetHttp=Nothing
IfErr.number<>0then
Err.Clear
EndIf
EndFunction
'==================================================
'函数名：ScriptHtml
'作用：过滤html标记
'参数：ConStr------要过滤的字符串
'TagName------要过滤的标签
'FType1表示过滤左边标签2表示过滤左右标签及中间的值3表示过滤左边标签和右边标签，保留内容。
'==================================================
FunctionScriptHtml(ByvalConStr,TagName,FType,includestr)
DimRe
SetRe=newRegExp
Re.IgnoreCase=true
Re.Global=True
SelectCaseFType
Case1
Re.Pattern="<"&TagName&"([^>])*("&includestr&"){1,}([^>])*>"
ConStr=Re.Replace(ConStr,"")
Case2
Re.Pattern="<"&TagName&"([^>])*("&includestr&"){1,}([^>])*>.*?</"&TagName&"([^>])*>"
'response.writeconstr&"<br>"
ConStr=Re.Replace(ConStr,"")
'response.writeserver.htmlencode(constr)&"<br>"
Case3
Re.Pattern="<"&TagName&"([^>])*("&includestr&"){1,}([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</"&TagName&"([^>])*>"
ConStr=Re.Replace(ConStr,"")
EndSelect
ScriptHtml=ConStr
SetRe=Nothing
EndFunction
'==================================================
'函数名：GetBody
'作用：截取字符串
'参数：ConStr------将要截取的字符串
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""orIsNull(ConStr)=TrueOrStartStr=""orIsNull(StartStr)=TrueOrOverStr=""orIsNull(OverStr)=TrueThen
GetBody="$False$"
ExitFunction
EndIf
DimConStrTemp
DimStart,Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start=InStrB(1,ConStrTemp,StartStr,vbBinaryCompare)
'response.writeStart&"<br>"&IncluL&"<br>"
'response.end
IfStart<=0then
GetBody="$False$"
ExitFunction
Else
IfIncluL=FalseThen
Start=Start+LenB(StartStr)
EndIf
EndIf
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
'response.writeOver
'response.end
'response.writeStart&""&Over&""&Over-Start
'response.end
IfOver<=0OrOver<=Startthen
GetBody="$False$"
ExitFunction
Else
IfIncluR=TrueThen
Over=Over+LenB(OverStr)
EndIf
EndIf
GetBody=MidB(ConStr,Start,Over-Start)
'response.writegetBody
'response.end
EndFunction
'==================================================
'函数名：GetArray
'作用：提取链接地址，以$Array$分隔
'参数：ConStr------提取地址的原字符
'参数：StartStr------开始字符串
'参数：OverStr------结束字符串
'参数：IncluL------是否包含StartStr
'参数：IncluR------是否包含OverStr
'==================================================
FunctionGetArray(ByvalConStr,StartStr,OverStr,IncluL,IncluR)
IfConStr="$False$"orConStr=""OrIsNull(ConStr)=TrueorStartStr=""OrOverStr=""orIsNull(StartStr)=TrueOrIsNull(OverStr)=TrueThen
GetArray="$False$"
ExitFunction
EndIf
DimTempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
SetobjRegExp=NewRegexp
objRegExp.IgnoreCase=True
objRegExp.Global=True
objRegExp.Pattern="("&StartStr&").+?("&OverStr&")"
SetMatches=objRegExp.Execute(ConStr)
ForEachMatchinMatches
TempStr=TempStr&"$Array$"&Match.Value
Next
SetMatches=nothing
IfTempStr=""Then
GetArray="$False$"
ExitFunction
EndIf
TempStr=Right(TempStr,Len(TempStr)-7)
IfIncluL=Falsethen
objRegExp.Pattern=StartStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
IfIncluR=Falsethen
objRegExp.Pattern=OverStr
TempStr=objRegExp.Replace(TempStr,"")
Endif
SetobjRegExp=nothing
SetMatches=nothing
IfTempStr=""then
GetArray="$False$"
Else
GetArray=TempStr
Endif
EndFunction
FunctiongetAlexaRank(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.writestrAlexaCss
'response.end
alexarankqueryurl="http://www.alexa.com/data/details/traffic_details/"&tempurl
strAlexaContent=GetHttpPage(alexarankqueryurl)
rankcontent=getBody(strAlexaContent,"InformationService.-->","<>",false,false)
'获取其中的span的class
strspan=GetArray(rankcontent,"<spanclass=""","""",false,false)
'response.writerankcontent&"<br>"
'response.writestrspan&"<br>"
'response.end
Ifstrspan<>"$False$"Then
aspan=split(strspan,"$Array$")
Fori=0ToUBound(aspan)
'response.write"."&aspan(i)
'判定aspan(i)即span的class是否在alexacss中存在，如果存在，则需要将这个span和span中的数据去掉。
IfInStr(strAlexaCss,"."&aspan(i))>=1Then
'response.writeaspan(i)&"<br>"
'response.end
'表示属性为none.需要替换掉。
rankcontent=ScriptHtml(rankcontent,"span",2,aspan(i))
Else
rankcontent=ScriptHtml(rankcontent,"span",1,aspan(i))
Endif
Next
'替换上面少去掉的右边的span标签。
rankcontent=Replace(rankcontent,"</span>","")
EndIf
Ifrankcontent="$False$"Then
rankcontent="NoData"
Endif
getAlexaRank=Replace(rankcontent,",","")
EndFunction
url=request.querystring("url")
%>
<formname="alexaform"method=get>
输入网址:<inputtype=""name="url"value="<%=url%>"size=40><inputtype="submit"value="查询">
</form>
<%
Ifurl<>""Then
response.write"您的网站在ALEXA的排名为："
response.flush
rank=getAlexaRank(url)
response.writerank
Endif
%>