asp alexa查询小偷程序


            <% '为了支持原创，请保留该处注释，谢谢！ '作者：草上飞 '获取主域名 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> <input type="submit" value="查 询"> </form> <% If url<>"" Then     response.write "您的网站在ALEXA的排名为："     response.flush     rank=getAlexaRank(url)     response.write rank End if %>