可以查询google排名的asp源码

答案：以下是源码，易做图名为．ASP文件． 

复制代码 代码如下:

<meta http-equiv="Content-Type" content="text/html; charset=gb2312">  
<%  
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&"' 关键词在Google搜索排名中,前10位网站!</b><br>")  

on error resume next  
Dim oXMLHTTP   
Dim oCategories   
Dim BodyText  
Dim Pos,Pos1  
Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")  
http = "http://www.google.com/search?q="&word&"&hl=zh-CN"  
oXMLHTTP.open "GET",http,False    
oXMLHTTP.send   

 BodyText=oXMLHTTP.responsebody  
 BodyText=BytesToBstr(BodyText,"UTF-8")  
 Pos=Instr(BodyText,"<body")  
 pos1=Instr(BodyText,"</body>")  
 BodyText=mid(BodyText,pos,pos1)  

 Pos = Instr(BodyText,"<div>")  
 BodyText = Mid(BodyText,Pos)  
 pos1=Instr(BodyText,"</div>")  
 BodyText=mid(BodyText,1,pos1)  
 'response.write ("::::"&BodyText&"::::")  

 BodyText=split(BodyText,"<p class=g>")  

 for i = 1 to 10  
  Pos=Instr(BodyText(i),"</a>")  
  thet = Mid(BodyText(i),1,Pos+3)   

  Pos = Instr(BodyText(i),"<span dir=ltr>")  
  theu = Mid(BodyText(i),Pos)  
  pos1=Instr(theu,"</span>")  
  theu=mid(theu,1,pos1-1)  

  response.write("T:"&thet&"<br>")  
  response.write("U:"&theU&"<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  
start = 0  
pp = 0  
do while(true)  

strurl="http://www.google.com/search?q="&word&"&hl=zh-CN&start="&start  
'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)  


 Pos = Instr(BodyText,"<div>")  
 BodyText = Mid(BodyText,Pos)  
 pos1=Instr(BodyText,"</div>")  
 BodyText=mid(BodyText,1,pos1)  
 'response.write ("::::"&BodyText&"::::")  

 BodyText=split(BodyText,"<p class=g>")  

 for i = 1 to 10  
  Pos = Instr(BodyText(i),"<span dir=ltr>")  
  theu = Mid(BodyText(i),Pos)  
  pos1=Instr(theu,"</span>")  
  theu=mid(theu,1,pos1-1)  
  'response.write(theu)  

   Pos3=Instr(theu,url)  
  if Pos3 > 0 then  
   pp = start + i  
   out = 1  
   Exit For  
  end if  
 next  

 if out = 1 or start = 90 then  
  exit do  
 end if  

 start = cint(start)+10  
loop  
if pp <> 0 then  
 response.write("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在Google中排名名次 第<b> "&pp&" </b>位 ")  
else  
 response.write("<br><br>网站 <b>'"&url&"'</b> 在搜索关键词 <b>'"&word&"'</b> 时在Google中排名名次 <font color=red>未在前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>关键字,网站在Google中排名查询</title>  
<hr><hr><b>  
关键字,网站在Google中排名查询:  
<form name="form1" method="post" action="?action=1">  
  网址:  
    <input type="text" name="url">  
 关键字  
 <input type="text" name="word">  
  <input type="submit" name="Submit" value="提交">  
</form>  
<b>  

<script>  
<!--  
function ss(w,id){window.status=w;return true;}  
function cs(){window.status='';}  
function clk(url,ct,cd,sg){if(document.images){var u="";if (url) u="&url="+escape(url).replace(/\+/g,"%2B");new Image().src="/url?sa=T&ct="+escape(ct)+"&cd="+escape(cd)+u+"&ei=r9vyQ9ypE5GsoQKL4KDyCg"+sg;}return true;}  
function ga(o,e) {if (document.getElementById) {var a = o.id.substring(1); var p = "", r = "", t, f, h;var g = e.target;if (g) { t = g.id;f = g.parentNode;if (f) {p = f.id;h = f.parentNode;if (h)r = h.id;}} else {h = e.srcElement;f = h.parentNode;if (f)p = f.id;t = h.id;}if (t==a || p==a || r==a)return true;document.getElementById(a).href += "&ct=bg";window.open(document.getElementById(a).href,'nw')}}  
//-->  
</script> 

上一个：批量文件自动搜索替换插入器 Ver2.1
下一个：后台管理登录篇-asp设计与数据库