分享
 
 
 

ASP版Google pagerank查询系统(非偷取第三方网站数据)

王朝asp·作者佚名  2008-06-01
窄屏简体版  字體: |||超大  

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.knowsky.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>

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有