asp alexa查询小偷程序

1. <%  
2. '为了支持原创，请保留该处注释，谢谢！  
3. '作者：草上飞  
4. '获取主域名  
5. Function getDomainUrl(url)  
6.     tempurl=replace(url,"http://","")  
7.     if instr(tempurl,"/")>0 then  
8.         tempurl=left(tempurl,instr(tempurl,"/")-1)  
9.     end If  
10.     getDomainurl=tempurl  
11. End Function  
12.  
13.  
14. Function GetHttpPage(HttpUrl)  
15.    If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then  
16.       GetHttpPage="$False$"  
17.       Exit Function  
18.    End If  
19.    Dim Http  
20.    Set Http=server.createobject("MSXML2.XMLHTTP")  
21.    Http.open "GET",HttpUrl,False  
22.    Http.Send()  
23.    If Http.Readystate<>4 then  
24.       Set Http=Nothing   
25.       GetHttpPage="$False$"  
26.       Exit function  
27.    End if  
28.    GetHTTPPage=Http.responseText  
29.    Set Http=Nothing  
30.    If Err.number<>0 then  
31.       Err.Clear  
32.    End If  
33. End Function  
34.  
35. '==================================================  
36. '函数名：ScriptHtml  
37. '作  用：过滤html标记  
38. '参  数：ConStr ------ 要过滤的字符串  
39. '         TagName ------要过滤的标签  
40. '         FType 1表示过滤左边标签  2表示过滤左右标签及中间的值  3表示过滤左边标签和右边标签，保留内容。  
41. '==================================================  
42. Function ScriptHtml(Byval ConStr,TagName,FType,includestr)  
43.     Dim Re  
44.     Set Re=new RegExp  
45.     Re.IgnoreCase =true  
46.     Re.Global=True  
47.     Select Case FType  
48.     Case 1  
49.        Re.Pattern="<" & TagName & "([^>])*("&includestr&"){1,}([^>])*>"  
50.        ConStr=Re.Replace(ConStr,"")  
51.     Case 2  
52.        Re.Pattern="<" & TagName & "([^>])*("&includestr&"){1,}([^>])*>.*?</" & TagName & "([^>])*>"  
53.        'response.write constr&"<br>"  
54.        ConStr=Re.Replace(ConStr,"")  
55.        'response.write server.htmlencode(constr)&"<br>"  
56.     Case 3  
57.         Re.Pattern="<" & TagName & "([^>])*("&includestr&"){1,}([^>])*>"  
58.        ConStr=Re.Replace(ConStr,"")  
59.        Re.Pattern="</" & TagName & "([^>])*>"  
60.        ConStr=Re.Replace(ConStr,"")  
61.     End Select  
62.     ScriptHtml=ConStr  
63.     Set Re=Nothing  
64. End Function  
65.  
66. '==================================================  
67. '函数名：GetBody  
68. '作  用：截取字符串  
69. '参  数：ConStr ------将要截取的字符串  
70. '参  数：StartStr ------开始字符串  
71. '参  数：OverStr ------结束字符串  
72. '参  数：IncluL ------是否包含StartStr  
73. '参  数：IncluR ------是否包含OverStr  
74. '==================================================  
75. Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)  
76.    If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then  
77.       GetBody="$False$"  
78.       Exit Function  
79.    End If  
80.    Dim ConStrTemp  
81.    Dim Start,Over  
82.    ConStrTemp=Lcase(ConStr)  
83.    StartStr=Lcase(StartStr)  
84.    OverStr=Lcase(OverStr)  
85.    Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)  
86.    'response.write Start&"<br>"&IncluL&"<br>"  
87.    'response.end  
88.    If Start<=0 then  
89.       GetBody="$False$"  
90.       Exit Function  
91.    Else  
92.       If IncluL=False Then  
93.          Start=Start+LenB(StartStr)  
94.       End If  
95.    End If  
96.    Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)  
97.    'response.write Over  
98.    'response.end  
99.    'response.write Start&"  "&Over&"  "&Over-Start  
100.    'response.end  
101.    If Over<=0 Or Over<=Start then  
102.       GetBody="$False$"  
103.       Exit Function  
104.    Else  
105.       If IncluR=True Then  
106.          Over=Over+LenB(OverStr)  
107.       End If  
108.    End If  
109.  
110.    GetBody=MidB(ConStr,Start,Over-Start)  
111.    'response.write getBody  
112.    'response.end  
113. End Function  
114.  
115. '==================================================  
116. '函数名：GetArray  
117. '作  用：提取链接地址，以$Array$分隔  
118. '参  数：ConStr ------提取地址的原字符  
119. '参  数：StartStr ------开始字符串  
120. '参  数：OverStr ------结束字符串  
121. '参  数：IncluL ------是否包含StartStr  
122. '参  数：IncluR ------是否包含OverStr  
123. '==================================================  
124. Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)  
125.    If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then  
126.       GetArray="$False$"  
127.       Exit Function  
128.    End If  
129.    Dim TempStr,TempStr2,objRegExp,Matches,Match  
130.    TempStr=""  
131.    Set objRegExp = New Regexp   
132.    objRegExp.IgnoreCase = True   
133.    objRegExp.Global = True  
134.    objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"  
135.    Set Matches =objRegExp.Execute(ConStr)   
136.    For Each Match in Matches  
137.       TempStr=TempStr & "$Array$" & Match.Value  
138.    Next   
139.    Set Matches=nothing  
140.  
141.    If TempStr="" Then  
142.       GetArray="$False$"  
143.       Exit Function  
144.    End If  
145.    TempStr=Right(TempStr,Len(TempStr)-7)  
146.    If IncluL=False then  
147.       objRegExp.Pattern =StartStr  
148.       TempStr=objRegExp.Replace(TempStr,"")  
149.    End if  
150.    If IncluR=False then  
151.       objRegExp.Pattern =OverStr  
152.       TempStr=objRegExp.Replace(TempStr,"")  
153.    End if  
154.    Set objRegExp=nothing  
155.    Set Matches=nothing  
156.  
157.    If TempStr="" then  
158.       GetArray="$False$"  
159.    Else  
160.       GetArray=TempStr  
161.    End if  
162. End Function  
163.  
164. Function getAlexaRank(weburl)  
165.     tempurl=getDomainUrl(weburl)  
166.     '读取http://client.alexa.com/common/css/scramble.css中的数据  
167.     alexacss="http://client.alexa.com/common/css/scramble.css"  
168.     strAlexaCss=GetHttpPage(alexacss)  
169.     'response.write strAlexaCss  
170.     'response.end  
171.     alexarankqueryurl="http://www.alexa.com/data/details/traffic_details/"&tempurl  
172.  
173.     strAlexaContent=GetHttpPage(alexarankqueryurl)  
174.  
175.     rankcontent=getBody(strAlexaContent,"Information Service.-->","<!-- google_ad_section_end(name=default) -->",false,false)  
176.     '获取其中的span的class  
177.     strspan=GetArray(rankcontent,"<span class=""","""",false,false)  
178.     'response.write rankcontent&"<br>"  
179.     'response.write strspan&"<br>"  
180.     'response.end  
181.     If strspan<>"$False$" Then  
182.         aspan=split(strspan,"$Array$")  
183.  
184.         For i=0 To UBound(aspan)  
185.             'response.write "."&aspan(i)  
186.             '判定aspan(i)即span的class是否在alexacss中存在，如果存在，则需要将这个span和span中的数据去掉。  
187.             If InStr(strAlexaCss,"."&aspan(i))>=1 Then  
188.                 'response.write aspan(i)&"<br>"  
189.                 'response.end  
190.                 '表示属性为none.需要替换掉。  
191.                 rankcontent=ScriptHtml(rankcontent,"span",2,aspan(i))  
192.             Else  
193.                 rankcontent=ScriptHtml(rankcontent,"span",1,aspan(i))  
194.             End if  
195.         Next  
196.         '替换上面少去掉的右边的span标签。  
197.         rankcontent=Replace(rankcontent,"</span>","")  
198.  
199.           
200.     End If  
201.     If rankcontent="$False$" Then   
202.         rankcontent="No Data"  
203.     End if  
204.     getAlexaRank=Replace(rankcontent,",","")  
205.  
206. End Function  
207. url=request.querystring("url")  
208. %>  
209.  
210. <form name="alexaform" method=get>  
211.     输入网址:<input type="" name="url" value="<%=url%>" size=40> <input type="submit" value="查 询">  
212. </form>  
213. <%  
214. If url<>"" Then  
215.  
216.     response.write "您的网站在ALEXA的排名为："  
217.     response.flush  
218.     rank=getAlexaRank(url)  
219.     response.write rank  
220. End if  
221. %>