O sistema de consulta de pagerank do Google (que não rouba dados de sites de terceiros) vem com três páginas de exemplo deste programa, e a categoria de aquisição remota é muito boa,
demonstração da página de consulta de pagerank do Google: http://www.knowsky.com/tools/ . pr/
三páginas:
CLS_Asphttp.asp
<%
Classe FlyCms_AspHttp
oForm público,oXml,Ados
StrHeaders públicos
Método público
URL público
Referente público
sSetCookie público
Linguagem pública
CONTEÚDO público
Agente Público
Codificação pública
Aceitação pública
Dados públicos
Base de código pública
Privado slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
' ===========================================
'Inicialização do módulo de classe
' ===========================================
Subclasse Privada_Initialize()
oFormulário = ""
Definir oXml = Server.CreateObject("MSXML2.ServerXMLHTTP")
definir Ados = Server.CreateObject("Adodb.Stream")
slresolveTimeout = 20000 'Tempo limite para resolução de nomes DNS, 20 segundos
slconnectTimeout = 20000 'Tempo limite para estabelecer conexão Winsock, 20 segundos
slsendTimeout = 30000 'Tempo limite para envio de dados, 30 segundos
slreceiveTimeout = 30000 ' Tempo limite para recebimento de resposta, 30 segundos
Fim Sub
' ===========================================
'Tempo limite para resolução de nomes DNS
' ===========================================
Propriedade pública Let lresolveTimeout(LngSize)
Se IsNumeric(LngSize) então
slresolveTimeout = Clng(LngSize)
Terminar se
Fim da propriedade
' ===========================================
'Tempo limite para estabelecer conexão Winsock
' ===========================================
Propriedade pública Let lconnectTimeout(LngSize)
Se IsNumeric(LngSize) então
slconnectTimeout = Clng(LngSize)
Terminar se
Fim da propriedade
' ===========================================
'Tempo limite para envio de dados
' ===========================================
Propriedade pública Let lsendTimeout(LngSize)
Se IsNumeric(LngSize) então
slsendTimeout = Clng(LngSize)
Terminar se
Fim da propriedade
' ===========================================
'Tempo limite para receber resposta
' ===========================================
Propriedade pública Let lreceiveTimeout(LngSize)
Se IsNumeric(LngSize) então
slreceiveTimeout = Clng(LngSize)
Terminar se
Fim da propriedade
' ===========================================
'Método
' ===========================================
Método Let de propriedade pública (strMethod)
sMethod = strMethod
Fim da propriedade
' ===========================================
'Enviar url
' ===========================================
Propriedade pública Let Url(strUrl)
sUrl = strUrl
Fim da propriedade
' ===========================================
'Dados
' ===========================================
Propriedade pública Let Data(strData)
sData = strData
Fim da propriedade
' ===========================================
'Referente
' ===========================================
Propriedade pública Let Referer(strReferer)
sReferer = strReferer
Fim da propriedade
' ===========================================
'DefinirCookie
' ===========================================
Propriedade pública Let SetCookie(strCookie)
sSetCookie = strCookie
Fim da propriedade
' ===========================================
'Linguagem
' ===========================================
Propriedade pública Let Language(strLanguage)
sIdioma = strIdioma
Fim da propriedade
' ===========================================
'Tipo CONTEÚDO
' ===========================================
Propriedade pública Deixe CONTENT(strCONTENT)
sCONTEÚDO = strCONTEÚDO
Fim da propriedade
' ===========================================
'Agente do Usuário
' ===========================================
Agente de propriedade pública (strAgent)
sAgente = strAgente
Fim da propriedade
' ===========================================
'Aceitar-codificação
' ===========================================
Propriedade pública Let Encoding (strEncoding)
sEncoding = strEncoding
Fim da propriedade
' ===========================================
'Aceitar
' ===========================================
Propriedade pública Let Accept(strAccept)
sAceitar = strAceitar
Fim da propriedade
' ===========================================
'CodeBase
' ===========================================
Propriedade pública Let CodeBase(strCodeBase)
sCodeBase = strCodeBase
Fim da propriedade
' ===========================================
'Criar direção de transferência de dados!
' ===========================================
Função pública AddItem(chave, valor)
Em caso de erro, retomar o próximo
Diminuir TempStr
Se oForm = "" Então
oForm = Chave + "=" + Server.URLEncode(Valor)
Outro
oForm = oForm + "&" + Chave + "=" + Server.URLEncode(Valor)
Terminar se
Função final
' ===========================================
'Enviar dados e recuperar dados remotos
' ===========================================
Função Pública HttpGet()
Dim retorno
Com oXml
.setTimeouts slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
.Abra sMethod,sUrl,Falso
Se sSetCookie<>"" Então
.setRequestHeader "Cookie", sSetCookie 'Definir Cookie
Terminar se
Se sReferer<>"" Então
.setRequestHeader "Referer", sReferer 'Definir fonte da página
Outro
.setRequestHeader "Referenciador", sUrl
Terminar se
Se sLanguage<>"" Então
.setRequestHeader "Accept-Language", sLanguage 'Definir idioma
Terminar se
.setRequestHeader "Content-Length",Len(sData) 'Definir comprimento dos dados
Se sCONTENT<>"" Então
.setRequestHeader "CONTENT-Type",sCONTENT 'Define o tipo de dados aceito
Terminar se
Se sAgente<>"" Então
.setRequestHeader "User-Agent", sAgent 'Definir navegador
Terminar se
Se sEncoding<>"" Então
.setRequestHeader "Accept-Encoding", sEncoding 'Definir compactação gzip
Terminar se
Se sAceitar<>"" Então
.setRequestHeader "Aceitar", sAccept 'Tipo de documento
Terminar se
Resposta.Write sData
.Send sData 'Enviar dados
Enquanto .readyState <> 4
.waitForResponse 1000
Wend
strHeaders =.getAllResponseHeaders()
Se sCodeBase<>"" Então
sReturn = bytes2BSTR(.responseBody)
Outro
sReturn = .responseBody
Terminar se
Terminar com
HttpGet = sReturn
Função final
' ===========================================
' Processa dados binários
' ===========================================
Função privada bytes2BSTR(vIn)
strReturn = ""
Para i = 1 para LenB(vIn)
EsteCharCode = AscB(MidB(vIn,i,1))
Se ThisCharCode <&H80 Então
strReturn = strReturn & Chr(ThisCharCode)
Outro
PróximoCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
eu = eu + 1
Terminar se
Próximo
bytes2BSTR = strReturn
Função final
' ===========================================
' Sair do módulo de classe
' ===========================================
Subclasse Privada_Terminate
oFormulário = ""
Definir oXml = Nada
Definir Ados=Nada
Finalizar sub
Fim da aula
%>
google.asp
<%
Const GOOGLE_MAGIC = &HE6359A60
Função sl (ByVal x, ByVal n)
Se n = 0 Então
sl = x
Outro
Escurecer
k = CLng(2 ^ (32 - n - 1))
Escurecer
d = x E (k - 1)
Escurecer c
c = d * CLng(2^n)
Se x e k então
c = c Ou &H80000000
Terminar se
sl = c
Terminar se
Função final
Função privada uadd (ByVal L1, ByVal L2)
Dim L11, L12, L21, L22, L31, L32
L11 = L1 E &HFFFFFF
L12 = (L1 E &H7F000000)&H1000000
Se L1 <0 Então L12 = L12 Ou &H80
L21 = L2 E &HFFFFFF
L22 = (L2 E &H7F000000)&H1000000
Se L2 <0 então L22 = L22 ou &H80
L32 = L12 + L22
L31 = L11 + L21
Se (L31 e &H1000000) Então L32 = L32 + 1
uadd = (L31 E &HFFFFFF) + (L32 E &H7F) * &H1000000
Se L32 e &H80 Então uadd = uadd Ou &H80000000
Função final
Mix de funções (ByVal ia, ByVal ib, ByVal ic)
Dim a, b, c
a = eu
b=ib
c = ic
a = usub(a, b)
uma = usub(a, c)
a = a Xou zeroFill(c, 13)
b = usub(b, c)
b = usub(b, a)
b = b Xou sl(a, 8)
b = usub(b, c)
b = usub(b, a)
b = b Xou sl(a, 10)
c = usub(c, a)
c = usub(c, b)
c = c Xou zeroFill(b, 15)
Dim ret(3)
ret(0) = a
ret(1) = b
ret(2) = c
mix = ret
Função Final
Função gc(ByVal s, ByVal i)
gc = Asc(Médio(s, i + 1, 1))
Função Final
Função GoogleCH(ByVal sUrl)
Dim iComprimento, a, b, c, k, iLen, m
iComprimento = Len(sUrl)
a = &H9E3779B9
b = &H9E3779B9
c=GOOGLE_MAGIC
k = 0
iLen = iComprimento
Faça enquanto 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 'todas as instruções case falham
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 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))
Caso 2
a = uadd(a, sl(gc(sUrl, k + 1), 8))
a = uadd(a, gc(sUrl, k + 0))
Caso 1
a = uadd(a, gc(sUrl, k + 0))
Finalizar seleção
m = mix(a, b, c)
GoogleCH = m(2)
Função Final
Função CalculaChecksum(sUrl)
CalculaChecksum = "6" & CStr(GoogleCH("info:" & sUrl))
Função final
%>
PR.asp
<!--#include file="google.asp"-->
<!--#include file="Cls_AspHttp.asp"-->
<%
SubRw(Str)
Response.Write Str & vbCrLf
Resposta.Flush
End Sub
Function HttpGet(lresolveTimeout,lconnectTimeout,Method,Url,Referer,Data,SetCookie,Language,CONTENT,Agent,Encoding,Accept,CodeBase)
Definir DoGet = Novo FlyCms_AspHttp
DoGet.lresolveTimeout = lresolveTimeout
DoGet.lconnectTimeout = lconnectTimeout
DoGet.lsendTimeout = lsendTimeout
DoGet.lreceiveTimeout = lreceiveTimeout
DoGet.Method = Método
DoGet.Url = URL
DoGet.Referer = Referente
DoGet.Data = Dados
DoGet.SetCookie = SetCookie
DoGet.Language = Idioma
DoGet.CONTENT = CONTEÚDO
DoGet.Agent = Agente
DoGet.Encoding = Codificação
DoGet.Accept = Aceitar
DoGet.CodeBase = CodeBase
HttpGet = DoGet.HttpGet()
Definir DoGet = Nada
Função Final
Função GGPR (URL ByVal)
Estreito escuro
sURL = " http://www.google.com/search?client=navclient&ch =" & CalculaCheck(URL) & "&features=Rank&q=info:" & URL
Rw "Endereço de consulta: " & sURL & "<br />"
strRet = HttpGet(10000,10000,20000,20000,"GET",sUrl,"","","","zh-cn","","Mozilla/4.0 (compatível; MSIE 6.0; Windows NT 5.1) ","","*/*","gb2312")
Se InStr(strRet,":") Então
R = Dividir(strRet,":")
GGPR = R(2)
Outro
GGPR = 0
Terminar se
Rw "Resultado do retorno: " & strRet & "<br />"
Rw " Valor PR: " & GGPR & "<br />"
Função final
iURL = Solicitação("iURL")
Se iURL="" Então iURL = " http://www.downcodes.com "
ChamarGGPR(iURL)
%>
<html>
<head></head>
<title>Consulta do Google Pagerank (ladrão de consultas pr)</title>
<corpo>
<h1>Insira o endereço completo da página para verificar o pagerank (valor PR da página):</h1>
<form action="" método="post">
URL <input type="text" name="iURL" style="width:200px" /><input type="submit" value="pr query" />
</form>
</body>
<html>