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 < 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
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 < 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 < 0 Then
        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