Google pagerank查詢系統（非偷取第三方網站資料）帶本程式範例三個頁面,其中的遠端取得類別非常不錯.
Google pagerank查詢頁面示範: http://www.knowsky.com/tools/pr/
三個頁面:
CLS_Asphttp.asp
<%
Class FlyCms_AspHttp
Public oForm,oXml,Ados
Public strHeaders
Public sMethod
Public sUrl
Public sReferer
Public sSetCookie
Public sLanguage
Public sCONTENT
Public sAgent
Public sEncoding
Public sAccept
Public sData
Public sCodeBase
Private slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
' ============================================
' 類別模組初始化
' ============================================
Private Sub Class_Initialize()
oForm = ""
Set oXml = Server.CreateObject("MSXML2.ServerXMLHTTP")
set Ados = Server.CreateObject("Adodb.Stream")
slresolveTimeout = 20000 ' 解析DNS名字的超時時間,20秒
slconnectTimeout = 20000 ' 建立Winsock連線的逾時時間,20秒
slsendTimeout = 30000 ' 發送資料的逾時時間,30秒
slreceiveTimeout = 30000 ' 接收response的超時時間,30秒
End Sub
' ==============================================
' 解析DNS名字的超時時間
' ============================================
Public Property Let lresolveTimeout(LngSize)
If IsNumeric(LngSize) Then
slresolveTimeout = Clng(LngSize)
End If
End Property
' ============================================
' 建立Winsock連線的逾時時間
' ============================================
Public Property Let lconnectTimeout(LngSize)
If IsNumeric(LngSize) Then
slconnectTimeout = Clng(LngSize)
End If
End Property
' ============================================
' 發送資料的超時時間
' ============================================
Public Property Let lsendTimeout(LngSize)
If IsNumeric(LngSize) Then
slsendTimeout = Clng(LngSize)
End If
End Property
' ============================================
' 接收response的超時時間
' ============================================
Public Property Let lreceiveTimeout(LngSize)
If IsNumeric(LngSize) Then
slreceiveTimeout = Clng(LngSize)
End If
End Property
' ============================================
' Method
' ============================================
Public Property Let Method(strMethod)
sMethod = strMethod
End Property
' ============================================
' 發送url
' ============================================
Public Property Let Url(strUrl)
sUrl = strUrl
End Property
' ============================================
' Data
' ============================================
Public Property Let Data(strData)
sData = strData
End Property
' ============================================
' Referer
' ============================================
Public Property Let Referer(strReferer)
sReferer = strReferer
End Property
' ============================================
' SetCookie
' ============================================
Public Property Let SetCookie(strCookie)
sSetCookie = strCookie
End Property
' ============================================
' Language
' ============================================
Public Property Let Language(strLanguage)
sLanguage = strLanguage
End Property
' ============================================
' CONTENT-Type
' ============================================
Public Property Let CONTENT(strCONTENT)
sCONTENT = strCONTENT
End Property
' ============================================
' User-Agent
' ============================================
Public Property Let Agent(strAgent)
sAgent = strAgent
End Property
' ============================================
' Accept-Encoding
' ============================================
Public Property Let Encoding(strEncoding)
sEncoding = strEncoding
End Property
' ============================================
' Accept
' ============================================
Public Property Let Accept(strAccept)
sAccept = strAccept
End Property
' ============================================
' CodeBase
' ============================================
Public Property Let CodeBase(strCodeBase)
sCodeBase = strCodeBase
End Property
' ============================================
' 建立資料傳送對向!
' ============================================
Public Function AddItem(Key, Value)
On Error Resume Next
Dim TempStr
If oForm = "" Then
oForm = Key + "=" + Server.URLEncode(Value)
Else
oForm = oForm + "&" + Key + "=" + Server.URLEncode(Value)
End If
End Function
' ============================================
' 發送數據並取回遠端數據
' ============================================
Public Function HttpGet()
Dim sReturn
With oXml
.setTimeouts slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
.Open sMethod,sUrl,False
If sSetCookie<>"" Then
.setRequestHeader "Cookie", sSetCookie '設定Cookie
End If
If sReferer<>"" Then
.setRequestHeader "Referer", sReferer '設定頁面來源
Else
.setRequestHeader "Referer", sUrl
End If
If sLanguage<>"" Then
.setRequestHeader "Accept-Language", sLanguage '設定語言
End If
.setRequestHeader "Content-Length",Len(sData) '設定資料長度
If sCONTENT<>"" Then
.setRequestHeader "CONTENT-Type",sCONTENT '設定接受資料類型
End If
If sAgent<>"" Then
.setRequestHeader "User-Agent", sAgent '設定瀏覽器
End If
If sEncoding<>"" Then
.setRequestHeader "Accept-Encoding", sEncoding '設定gzip壓縮
End If
If sAccept<>"" Then
.setRequestHeader "Accept", sAccept '文件類型
End If
Response.Write sData
.Send sData '發送數據
While .readyState <> 4
.waitForResponse 1000
Wend
strHeaders = .getAllResponseHeaders()
If sCodeBase<>"" Then
sReturn = bytes2BSTR(.responseBody)
Else
sReturn = .responseBody
End If
End With
HttpGet = sReturn
End Function
' ============================================
' 處理二進位數據
' ============================================
Private Function bytes2BSTR(vIn)
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function
' ============================================
' 類模組註銷
' ============================================
Private Sub Class_Terminate
oForm = ""
Set oXml = Nothing
Set Ados = Nothing
End Sub
End Class
%>
google.asp
<%
Const GOOGLE_MAGIC = &HE6359A60
Function sl(ByVal x, ByVal n)
If n = 0 Then
sl = x
Else
Dim k
k = CLng(2 ^ (32 - n - 1))
Dim d
d = x And (k - 1)
Dim c
c = d * CLng(2 ^ n)
If x And k Then
c = c Or &H80000000
End If
sl = c
End If
End Function
Private Function uadd(ByVal L1, ByVal L2)
Dim L11, L12, L21, L22, L31, L32
L11 = L1 And &HFFFFFF
L12 = (L1 And &H7F000000) &H1000000
If L1 < 0 Then L12 = L12 Or &H80
L21 = L2 And &HFFFFFF
L22 = (L2 And &H7F000000) &H1000000
If L2 < 0 Then L22 = L22 Or &H80
L32 = L12 + L22
L31 = L11 + L21
If (L31 And &H1000000) Then L32 = L32 + 1
uadd = (L31 And &HFFFFFF) + (L32 And &H7F) * &H1000000
If L32 And &H80 Then uadd = uadd Or &H80000000
End Function
Function mix(ByVal ia, ByVal ib, ByVal ic)
Dim a, b, c
a = ia
b = ib
c = ic
a = usub(a, b)
a = usub(a, c)
a = a Xor zeroFill(c, 13)
b = usub(b, c)
b = usub(b, a)
b = b Xor sl(a, 8)
b = usub(b, c)
b = usub(b, a)
b = b Xor sl(a, 10)
c = usub(c, a)
c = usub(c, b)
c = c Xor zeroFill(b, 15)
Dim ret(3)
ret(0) = a
ret(1) = b
ret(2) = c
mix = ret
End Function
Function gc(ByVal s, ByVal i)
gc = Asc(Mid(s, i + 1, 1))
End Function
Function GoogleCH(ByVal sUrl)
Dim iLength, a, b, c, k, iLen, m
iLength = Len(sUrl)
a = &H9E3779B9
b = &H9E3779B9
c = GOOGLE_MAGIC
k = 0
iLen = iLength
Do While iLen >= 12
a = uadd(a, (uadd(gc(sUrl, k + 0), uadd(sl(gc(sUrl, k + 1), 8), uadd(sl(gc(sUrl, k + 2), 16), sl(gc(sUrl, k + 3), 24))))))
b = uadd(b, (uadd(gc(sUrl, k + 4), uadd(sl(gc(sUrl, k + 5), 8), uadd(sl(gc(sUrl, k + 6), 16), sl(gc(sUrl, k + 7), 24))))))
m = mix(a, b, c)
a = m(0)
b = m(1)
c = m(2)
k = k + 12
iLen = iLen - 12
Loop
c = uadd(c, iLength)
Select Case iLen ' all the case statements fall through
Case 11
c = uadd(c, sl(gc(sUrl, k + 10), 24))
c = uadd(c, sl(gc(sUrl, k + 9), 16))
c = uadd(c, sl(gc(sUrl, k + 8), 8))
b = uadd(b, sl(gc(sUrl, k + 7), 24))
b = uadd(b, sl(gc(sUrl, k + 6), 16))
b = uadd(b, sl(gc(sUrl, k + 5), 8))
Case 10
c = uadd(c, sl(gc(sUrl, k + 9), 16))
c = uadd(c, sl(gc(sUrl, k + 8), 8))
b = uadd(b, sl(gc(sUrl, k + 7), 24))
b = uadd(b, sl(gc(sUrl, k + 6), 16))
b = uadd(b, sl(gc(sUrl, k + 5), 8))
b = uadd(b, gc(sUrl, k + 4))
Case 9
c = uadd(c, sl(gc(sUrl, k + 8), 8))
b = uadd(b, sl(gc(sUrl, k + 7), 24))
b = uadd(b, sl(gc(sUrl, k + 6), 16))
b = uadd(b, sl(gc(sUrl, k + 5), 8))
b = uadd(b, gc(sUrl, k + 4))
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 8
b = uadd(b, sl(gc(sUrl, k + 7), 24))
b = uadd(b, sl(gc(sUrl, k + 6), 16))
b = uadd(b, sl(gc(sUrl, k + 5), 8))
b = uadd(b, gc(sUrl, k + 4))
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 7
b = uadd(b, sl(gc(sUrl, k + 6), 16))
b = uadd(b, sl(gc(sUrl, k + 5), 8))
b = uadd(b, gc(sUrl, k + 4))
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 6
b = uadd(b, sl(gc(sUrl, k + 5), 8))
b = uadd(b, gc(sUrl, k + 4))
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 5
b = uadd(b, gc(sUrl, k + 4))
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 4
a = uadd(a, sl(gc(sUrl, k + 3), 24))
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 3
a = uadd(a, sl(gc(sUrl, k + 2), 16))
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 2
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Case 1
a = uadd(a, gc(sUrl, k + 0))
End Select
m = mix(a, b, c)
GoogleCH = m(2)
End Function
Function CalculateChecksum(sUrl)
CalculateChecksum = "6" & CStr(GoogleCH("info:" & sUrl))
End Function
%>
PR.asp
<!--#include file="google.asp"-->
<!--#include file="Cls_AspHttp.asp"-->
<%
Sub Rw(Str)
Response.Write Str & vbCrLf
Response.Flush
End Sub
Function HttpGet(lresolveTimeout,lconnectTimeout,Method,Url,Referer,Data,SetCookie,Language,CONTENT,Agent,Encoding,Accept,CodeBase)
Set DoGet = New FlyCms_AspHttp
DoGet.lresolveTimeout = lresolveTimeout
DoGet.lconnectTimeout = lconnectTimeout
DoGet.lsendTimeout = lsendTimeout
DoGet.lreceiveTimeout = lreceiveTimeout
DoGet.Method = Method
DoGet.Url = Url
DoGet.Referer = Referer
DoGet.Data = Data
DoGet.SetCookie = SetCookie
DoGet.Language = Language
DoGet.CONTENT = CONTENT
DoGet.Agent = Agent
DoGet.Encoding = Encoding
DoGet.Accept = Accept
DoGet.CodeBase = CodeBase
HttpGet = DoGet.HttpGet()
Set DoGet = Nothing
End Function
Function GGPR(ByVal URL)
Dim strRet
sURL = " http://www.google.com/search?client=navclient&ch =" & CalculateCheck(URL) & "&features=Rank&q=info:" & URL
Rw "查詢位址: " & sURL & "<br />"
strRet = HttpGet(10000,10000,20000,20000,"GET",sUrl,"","","","zh--cn","","Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1) ","","*/*","gb2312")
If InStr(strRet,":") Then
R = Split(strRet,":")
GGPR = R(2)
Else
GGPR = 0
End If
Rw "回傳結果: " & strRet & "<br />"
Rw " PR值: " & GGPR & "<br />"
End Function
iURL = Request("iURL")
If iURL="" Then iURL = " http://www.downcodes.com "
Call GGPR(iURL)
%>
<html>
<head></head>
<title>Google Pagerank 查詢(pr查詢小偷)</title>
<body>
<h1>輸入完整頁面位址查選pagerank(頁面pr值):</h1>
<form action="" method="post">
URL <input type="text" name="iURL" style="width:200px" /><input type="submit" value="pr查詢" />
</form>
</body>
<html>