<%
'为了支持原创，请保留该处注释，谢谢！
'作者：草上飞
'获取主域名
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
%>
如对本文有疑问，
点击进行留言回复！！
我要评论
网友评论