% 
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, ">", "gt;") 
   fString = replace(fString, "", "lt;") 
   fString = Replace(fString, CHR(32), " ")  'nbsp; 
   fString = Replace(fString, CHR(9), " ")   'nbsp; 
   fString = Replace(fString, CHR(34), "quot;") 
   fString = Replace(fString, CHR(39), "#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>