以下是源码，请命名为.asp文件
复制代码 代码如下:
<%
bpn = request(“bpn”)
if(bpn = “”) then
bpn = “0”
end if
intbpn = cint(bpn)
if request(“action”) = “1” then
word = request(“word”)
url = request(“url”)
if word “” then
getCategories()
if url “” then
getCategories2()
end if
end if
end if
Function getCategories()
response.write(“‘”&word&”‘ 关键词在百度搜索排名中,前10位网站!
“)
on error resume next
Dim oXMLHTTP
Dim oCategories
Dim BodyText
Dim Pos,Pos1
Set oXMLHTTP = CreateObject(“Microsoft.XMLHTTP”)
oXMLHTTP.open “GET”,”http://www.baidu.com/baidu?word=”&word,False
oXMLHTTP.send
BodyText=oXMLHTTP.responsebody
BodyText=BytesToBstr(BodyText,”gb2312″)
Pos=Instr(BodyText,”<body")
pos1=Instr(BodyText,””)
BodyText=mid(BodyText,pos,pos1)
BodyText=split(BodyText,”<table")
st = 5
for i = 1 to 10
thei = st + i
Pos=Instr(BodyText(thei),”<td")
pos1=Instr(BodyText(thei),”
“)
Body=mid(BodyText(thei),pos,len(BodyText(thei))-pos)
body1=split(body,”
“)
title = body1(0)
theurl = body1(2)
theurl = replace(theurl,”上的更多结果”,””)
response.write (“T:”& title)
response.write (“
“)
response.write (“U:”& theurl)
response.write (“
“)
next
Set oXMLHTTP = Nothing
if err.number0 then
response.write “出错了，错误描述：”&err.description & “
错误来源”& err.source
response.End()
end if
End Function
Function getCategories2()
on error resume next
Dim oXMLHTTP ‘ As Object
Dim oCategories ‘ As Object
Dim BodyText
Dim Pos,Pos1
Set oXMLHTTP = CreateObject(“Microsoft.XMLHTTP”)
out = 0
pn = 0
pp = 0
do while(true)
strurl=”http://www.baidu.com/baidu?word=”&word&”&pn=”&cint(pn)+intbpn*10
//response.write(strurl&”
“)
oXMLHTTP.open “GET”,strurl,False
oXMLHTTP.send
BodyText=oXMLHTTP.responsebody
BodyText=BytesToBstr(BodyText,”gb2312″)
Pos=Instr(BodyText,”<body")
pos1=Instr(BodyText,””)
BodyText=mid(BodyText,pos,pos1)
BodyText=split(BodyText,”<table")
st = 5
thei = 0
for i = 1 to 10
thei = st + i
//response.write(thei)
Pos=Instr(BodyText(thei),”<td")
pos1=Instr(BodyText(thei),”
“)
Body=mid(BodyText(thei),pos,len(BodyText(thei))-pos)
Pos3=Instr(Body,url)
if Pos3 > 0 then
pp = pn + i
out = 1
Exit For
end if
next
if out = 1 or pn = 90 then
exit do
end if
pn = cint(pn)+10
loop
if pp 0 then
response.write(“
网站 ‘”&url&”‘ 在搜索关键词 ‘”&word&”‘ 时在百度中排名名次 第 “&pp+intbpn*10&” 位 “)
else
response.write(“
网站 ‘”&url&”‘ 在搜索关键词 ‘”&word&”‘ 时在百度中排名名次 未在”&intbpn*10+1&”名到”&intbpn*10+100&”内”)
end if
Set oXMLHTTP = Nothing
if err.number0 then
response.write “出错了，错误描述：”&err.description & “
错误来源”& err.source
response.End()
end if
End Function
Function BytesToBstr(body,Cset)
dim objstream
set objstream = Server.CreateObject(“adodb.stream”)
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = nothing
End Function
Public Function HTMLEncode(fString)
If Not IsNull(fString) Then
fString = replace(fString, “>”, “>”)
fString = replace(fString, “<", "<")
fString = Replace(fString, CHR(32), ” “) ‘
fString = Replace(fString, CHR(9), ” “) ‘
fString = Replace(fString, CHR(34), “"”)
fString = Replace(fString, CHR(39), “'”) ‘单引号过滤
fString = Replace(fString, CHR(13), “”)
fString = Replace(fString, CHR(10) & CHR(10), “
“)
fString = Replace(fString, CHR(10), “
“)
HTMLEncode = fString
End If
End Function
%>
关键字,网站在百度中排名查询:
网址:
<input type="text" name="url" value="”>
关键字:
<input type="text" name="word" value="”>
查询范围:
<option value="0" >1-100
<option value="10" >101-200
<option value="20" >201-300
<option value="30" >301-400
<option value="40" >401-500
<option value="50" >501-600
<option value="60" >601-700
<option value="70" >701-800
<option value="80" >801-900
<option value="90" >901-1000