Option Explicit
'计算谷歌pr查询加密参数模块
'示例: "http://toolbarqueries.google.com/search?client=navclient-auto&ch=" & GetGoogleKey("www.baidu.com") & "&ie=UTF-8&oe=UTF-8&features=Rank:FVN&q=info:" & "www.baidu.com"
'算法有点问题,部分参数计算错误。影响不是太大。
Const GOOGLE_MAGIC = &HE6359A60
Function GetGoogleKey(Url) As String '获取加密参数
GetGoogleKey = "6" & CStr(GoogleCH("info:" & Url)) ' And &H7FFFFFFF)
End Function
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
Function Sr(ByVal x, ByVal n)
If n = 0 Then
Sr = x
Else
Dim y
y = x And &H7FFFFFFF
Dim z
If n = 32 - 1 Then
z = 0
Else
z = y CLng(2 ^ n)
End If
If y x Then
z = z Or CLng(2 ^ (32 - n - 1))
End If
Sr = z
End If
End Function
Function ZeroFill(ByVal a, ByVal b)
Dim x
If (&H80000000 And a) Then
x = Sr(a, 1)
x = x And (Not &H80000000)
x = x Or &H40000000
x = Sr(x, b - 1)
Else
x = Sr(a, b)
End If
ZeroFill = x
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
L21 = L2 And &HFFFFFF
L22 = (L2 And &H7F000000) &H1000000
If L2
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
Private Function Usub(ByVal L1, ByVal L2)
Dim L11, L12, L21, L22, L31, L32
L11 = L1 And &HFFFFFF
L12 = (L1 And &H7F000000) &H1000000
If L1
L21 = L2 And &HFFFFFF
L22 = (L2 And &H7F000000) &H1000000
If L2
L32 = L12 - L22
L31 = L11 - L21
If L31
L32 = L32 - 1
L31 = L31 + &H1000000
End If
Usub = L31 + (L32 And &H7F) * &H1000000
If L32 And &H80 Then Usub = Usub 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)
c = Usub(c, a)
c = Usub(c, b)
c = c Xor ZeroFill(b, 13)
a = Usub(a, b)
a = Usub(a, c)
a = a Xor ZeroFill(c, 12)
b = Usub(b, c)
b = Usub(b, a)
b = b Xor Sl(a, 16)
c = Usub(c, a)
c = Usub(c, b)
c = c Xor ZeroFill(b, 5)
a = Usub(a, b)
a = Usub(a, c)
a = a Xor ZeroFill(c, 3)
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))))))
c = Uadd(c, (Uadd(Gc(sUrl, k + 8), Uadd(Sl(Gc(sUrl, k + 9), 8), Uadd(Sl(Gc(sUrl, k + 10), 16), Sl(Gc(sUrl, k + 11), 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))
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 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))
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 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
文章来源于lcx.cc:【VB源码】VB计算谷歌pr查询加密参数模块
今天看了一下，有些友情链接失效了，所以摘除了。在以下列表里有摘除的链接，以及具体原因。本站会不定期检查友情链接，同时也欢迎新朋友前来做友情链接，请在此留言：>。 本站留言系统是即时提醒的。只要本人在线，基本上一有新留言，3秒内本人会收到提…
- 左青龙
- 微信扫一扫
-
- 右白虎
- 微信扫一扫
-
评论