% '為了支持原創，請保留該處注釋，謝謝！ '作者：草上飛 '獲取主域名 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 %>
