% '为了支持原创，请保留该处注释，谢谢！ '作者：草上飞 '获取主域名 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,}([^>])*>.*?/" 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
'================================================== '函数名：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"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
'================================================== '函数名：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.-->","!-- 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中的数据去掉。 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> 输入网址:input type="" name="url" value="%=url%>" size=40>nbsp;input type="submit" value="查 询"> /form> % If url>"" Then
response.write "您的网站在ALEXA的排名为：" response.flush rank=getAlexaRank(url) response.write rank End if %>
