<%@ CODEPAGE=65001 %>
<%
'///////////////////////////////////////////////////////////////////////////////
'// Search Google Rank
'// 作 者: 邓利强(duduwolf)
'// 版权所有: 嘟嘟老窝(http://duduwolf.winzheng.com/)
'// 技术支持: duduwolf@hotmail.com
'///////////////////////////////////////////////////////////////////////////////
%>
<% Option Explicit %>
<% 'On Error Resume Next %>
<% Response.Charset="UTF-8" %>
<% Response.Buffer=True %>
<%
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim url, skey, sContent, start, num, search
search = Request.Form("Search")
url = Request.Form("Url")
skey = Request.Form("Key")
start = Request.Form("start")
num = Request.Form("num")
Select Case search 'search是要查询的搜索引擎标示符，目前只用了gch这一个
Case "gen":sContent = getHTTPPage("http://www.google.com/search?q="&Server.URLEncode(skey)&"&hl=zh-CN&lr=&num="&num&"&start="&start)
Case "b":sContent = getHTTPPage("http://www.google.com/search?q="&Server.URLEncode(skey)&"&hl=zh-CN&lr=lang_zh-CN&num="&num&"&start="&start)
Case "gch":sContent = getHTTPPage("http://www.google.com/search?q="&Server.URLEncode(skey)&"&hl=zh-CN&lr=lang_zh-CN&num="&num&"&start="&start)
Case Else:
sContent = getHTTPPage("http://www.google.com/search?q="&Server.URLEncode(skey)&"&hl=zh-CN&lr=lang_zh-CN&num="&num&"&start="&start)
End Select
Response.Write(parseHtml(sContent, search, url, sKey, CInt(num), CInt(start)))
'Response.Write(sContent)
Response.End
End If
%>
Google关键字排名查询
<%
Function getHTTPPage(url)
Dim http
Set http=Server.CreateObject("Microsoft.XMLHTTP")
Http.open "GET",url,False
Http.setRequestHeader "Content-Type", "text/xml;charset=utf-8"
Http.send()
If Http.readystate<>4 Then
exit Function
End If
'getHTTPPage=bytes2BSTR(Http.responseBody) 我对编码不熟悉，通过responseBody得到的source再用通用函数bytes2BSTR转换后就变成乱码了，无奈下只能用responseText了，汗...
getHTTPPage=Http.responseText
Set http=Nothing
If err.number<>0 Then err.Clear
End Function
Function bytes2BSTR(vIn)
Dim strReturn
Dim i1,ThisCharCode,NextCharCode
strReturn = ""
For i1 = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i1,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i1+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i1 = i1 + 1
End If
Next
bytes2BSTR = strReturn
End Function
Function parseHtml(sContent, Search, Url, Key, Num, Start)
Dim sRtn, iPos, regex, Matches, Match, Count, qryCount
Dim ConstStr
ConstStr = "onmousedown=""return clk(this,'res',"
Set regex = new RegExp
regex.IgnoreCase = True
regex.Global = True
regex.Pattern = "有(.+)项符合"
Set Matches = regex.Execute(sContent)
If Matches.Count = 1 Then
qryCount = Replace(Replace(Replace(regex.Replace(Matches(0),"$1"),"",""),"",""), ",", "")
qryCount = CLng(qryCount)
iPos = InStr(sContent, Url)
If iPos>0 Then
If Start * Num > qryCount Then Response.Write("FAILED"&vbTab&"抱歉，已经从头查到尾共查了"&start+num&"条数据还是没有找到你指定的站点地址，是不是拼错了地址？还是关键字太复杂了？换一个试一下吧！"):Response.End
regex.Pattern = "]+>.+?"
Set Matches = regex.Execute(sContent)
Count = 0
For Each Match In Matches
If Instr(Match, Url) > 0 Then Count = Count + 1:Exit For
If Instr(Match, ConstStr) > 0 Then
Count = Count + 1
End If
Next
'If Start = 0 Then Start = 1
sRtn = "OK"&vbTab&"恭喜你找到了，你的站点"&Url&"在搜索引擎google中关键字"&Key&"的排名为第"&Count+Start&"名，收录的链接为："&Match&"，单击链接查看Google的查询结果http://www.google.com/search?q="&key&"&hl=zh-CN&lr=lang_zh-CN&num="&num&"&start="&start&""
Set Matches = Nothing
Else
num = start + num
If Start = 0 Then Start = 1
sRtn = "QUERY"&vbTab&"共有"&qryCount&"条查询结果，在"&start&" - "&num&"个查询结果中没有找到你的站点，是否继续？"
End If
Else
If Start <> 0 Then
sRtn = "FAILED"&vtTab&"在google的茫茫查询结果中，前"&Start*100&"条结果中没有找到你的站点，看来你还是换个关键字查查吧！"
Else
sRtn = "FAILED"&vbTab&"呜，太可悲了。你查询的关键字竟然在搜索引擎中找不到查询结果，请重新选一个关键字吧！"&vbTab&start&vbTab&num
End If
End If
Set regex = Nothing
parseHtml = sRtn
End Function
%>