可以查询百度排名的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>