可以查询百度排名的asp源码放送了

答案：以下是源码，易做图名为.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> 

上一个：将首页转成静态html页的asp文件
下一个：利用ActiveX控件InetCtls.Inet在ASP中实现新闻小偷