无为清净楼资源网 Design By www.qnjia.com
以下是源码,请命名为.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("<b>'"&word&"' 关键词在百度搜索排名中,前10位网站!</b><br>")
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,"</body>")
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),"</td>")
Body=mid(BodyText(thei),pos,len(BodyText(thei))-pos)
body1=split(body,"<br>")
title = body1(0)
theurl = body1(2)
theurl = replace(theurl,"上的更多结果","")
response.write ("T:"& title)
response.write ("<br>")
response.write ("U:"& theurl)
response.write ("<br><hr>")
next
Set oXMLHTTP = Nothing
if err.number<>0 then
response.write "出错了,错误描述:"&err.description & "<br>错误来源"& 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&"<br>")
oXMLHTTP.open "GET",strurl,False
oXMLHTTP.send
BodyText=oXMLHTTP.responsebody
BodyText=BytesToBstr(BodyText,"gb2312")
Pos=Instr(BodyText,"<body")
pos1=Instr(BodyText,"</body>")
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),"</td>")
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("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在百度中排名名次 第<b> "&pp+intbpn*10&" </b>位 ")
else
response.write("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在百度中排名名次 <font color=red>未在"&intbpn*10+1&"名到"&intbpn*10+100&"内</font>")
end if
Set oXMLHTTP = Nothing
if err.number<>0 then
response.write "出错了,错误描述:"&err.description & "<br>错误来源"& 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), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
HTMLEncode = fString
End If
End Function
%>
<title>关键字,网站在百度中排名查询</title>
<hr><hr><b>
关键字,网站在百度中排名查询:
<form name="form1" method="post" action="?action=1">
网址:
<input type="text" name="url" value="<%=url%>">
关键字:
<input type="text" name="word" value="<%=word%>">
查询范围:
<select name="bpn">
<option value="0" <%if(bpn = "0")then response.write("selected") end if%1-100</option>
<option value="10" <%if(bpn = "10")then response.write("selected") end if%101-200</option>
<option value="20" <%if(bpn = "20")then response.write("selected") end if%201-300</option>
<option value="30" <%if(bpn = "30")then response.write("selected") end if%301-400</option>
<option value="40" <%if(bpn = "40")then response.write("selected") end if%401-500</option>
<option value="50" <%if(bpn = "50")then response.write("selected") end if%501-600</option>
<option value="60" <%if(bpn = "60")then response.write("selected") end if%601-700</option>
<option value="70" <%if(bpn = "70")then response.write("selected") end if%701-800</option>
<option value="80" <%if(bpn = "80")then response.write("selected") end if%801-900</option>
<option value="90" <%if(bpn = "90")then response.write("selected") end if%901-1000</option>
</select>
<input type="submit" name="Submit" value="提交">
</form>
复制代码 代码如下:
<%
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("<b>'"&word&"' 关键词在百度搜索排名中,前10位网站!</b><br>")
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,"</body>")
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),"</td>")
Body=mid(BodyText(thei),pos,len(BodyText(thei))-pos)
body1=split(body,"<br>")
title = body1(0)
theurl = body1(2)
theurl = replace(theurl,"上的更多结果","")
response.write ("T:"& title)
response.write ("<br>")
response.write ("U:"& theurl)
response.write ("<br><hr>")
next
Set oXMLHTTP = Nothing
if err.number<>0 then
response.write "出错了,错误描述:"&err.description & "<br>错误来源"& 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&"<br>")
oXMLHTTP.open "GET",strurl,False
oXMLHTTP.send
BodyText=oXMLHTTP.responsebody
BodyText=BytesToBstr(BodyText,"gb2312")
Pos=Instr(BodyText,"<body")
pos1=Instr(BodyText,"</body>")
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),"</td>")
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("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在百度中排名名次 第<b> "&pp+intbpn*10&" </b>位 ")
else
response.write("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在百度中排名名次 <font color=red>未在"&intbpn*10+1&"名到"&intbpn*10+100&"内</font>")
end if
Set oXMLHTTP = Nothing
if err.number<>0 then
response.write "出错了,错误描述:"&err.description & "<br>错误来源"& 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), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
HTMLEncode = fString
End If
End Function
%>
<title>关键字,网站在百度中排名查询</title>
<hr><hr><b>
关键字,网站在百度中排名查询:
<form name="form1" method="post" action="?action=1">
网址:
<input type="text" name="url" value="<%=url%>">
关键字:
<input type="text" name="word" value="<%=word%>">
查询范围:
<select name="bpn">
<option value="0" <%if(bpn = "0")then response.write("selected") end if%1-100</option>
<option value="10" <%if(bpn = "10")then response.write("selected") end if%101-200</option>
<option value="20" <%if(bpn = "20")then response.write("selected") end if%201-300</option>
<option value="30" <%if(bpn = "30")then response.write("selected") end if%301-400</option>
<option value="40" <%if(bpn = "40")then response.write("selected") end if%401-500</option>
<option value="50" <%if(bpn = "50")then response.write("selected") end if%501-600</option>
<option value="60" <%if(bpn = "60")then response.write("selected") end if%601-700</option>
<option value="70" <%if(bpn = "70")then response.write("selected") end if%701-800</option>
<option value="80" <%if(bpn = "80")then response.write("selected") end if%801-900</option>
<option value="90" <%if(bpn = "90")then response.write("selected") end if%901-1000</option>
</select>
<input type="submit" name="Submit" value="提交">
</form>
无为清净楼资源网 Design By www.qnjia.com
广告合作:本站广告合作请联系QQ:858582 申请时备注:广告合作(否则不回)
免责声明:本站文章均来自网站采集或用户投稿,网站不提供任何软件下载或自行开发的软件! 如有用户或公司发现本站内容信息存在侵权行为,请邮件告知! 858582#qq.com
免责声明:本站文章均来自网站采集或用户投稿,网站不提供任何软件下载或自行开发的软件! 如有用户或公司发现本站内容信息存在侵权行为,请邮件告知! 858582#qq.com
无为清净楼资源网 Design By www.qnjia.com
暂无评论...
更新日志
2024年09月20日
2024年09月20日
- 黑神话悟空上品鼠弩手精魄获取方法一览|上品鼠弩手精魄收集攻略
- 中国音乐地图听见世界非物质文化遗产《非遗HQCD》wav
- 中国民乐合奏作品集《华夏之音HQ》头版限量编号[WAV+CUE]
- [电影原声带]黎允文《天将雄师》[FLAC+CUE]
- 曝NS继任机型已进入量产阶段:已花了30亿日元
- 不是Switch2?曝《马里奥惊奇》NS捆绑包即将公开
- 暖心任天堂!网友Switch维修返还时贴纸被完好保留
- 《国语老歌 经典对唱情歌 2CD》[WAV/分轨][1.1GB]
- 《刀郎 翻唱精选华语专辑 披着羊皮的狼 》[WAV+CUE][430MB]
- 《真的田震 中国乐坛红极一时的歌者 精品集》[WAV+CUE][300MB]
- 群星.1995-新滚石九大天王之情歌大全【滚石】【WAV+CUE】
- 群星.1993-滚石九大天王十二出好戏·纵夏欢唱【滚石】【WAV+CUE】
- 群星.1993-滚石九大天王十二出好戏·贺岁齐唱【滚石】【WAV+CUE】
- 黑神话悟空上品虫校尉精魄获取方法一览|上品虫校尉精魄收集攻略
- 《指环王:夏尔的传说》推迟至2025年初发行