VBA：Google翻译（含tk算法）

zhidaobu_com 2017-10-11

展开全文

完整的tk算法：

//源自http://translate.google.cn/
TKK=eval('((function(){var a\x3d618632403;var b\x3d1485484074;return 412204+\x27.\x27+(a+b)})())');
//会变动

//源自http://translate.google.cn/translate/releases/twsfe_20161212_RC00/r/js/desktop_module_main.js
var gk = function(a) {
    return function() {
        return a
    }
},
hk = function(a, b) {
    for (var c = 0; c < b.length - 2; c += 3) {
        var d = b.charAt(c + 2), d = "a" <= d ? d.charCodeAt(0) - 87 : Number(d), d = "+" == b.charAt(c + 1) ? a >>> d : a << d;
        a = "+" == b.charAt(c) ? a + d & 4294967295 : a ^ d
    }
    return a
},
ik = null, jk = function(a) {
    var b;
    if (null !== ik)
        b = ik;
    else {
        b = gk(String.fromCharCode(84));
        var c = gk(String.fromCharCode(75));
        b = [b(), b()];
        b[1] = c();
        b = (ik = window[b.join(c())] || "") || ""
    }
    var d = gk(String.fromCharCode(116)), c = gk(String.fromCharCode(107)), d = [d(), d()];
    d[1] = c();
    c = "&" + d.join("") +
    "=";
    d = b.split(".");
    b = Number(d[0]) || 0;
    for (var e = [], f = 0, g = 0; g < a.length; g++) {
        var l = a.charCodeAt(g);
        128 > l ? e[f++] = l : (2048 > l ? e[f++] = l >> 6 | 192 : (55296 == (l & 64512) && g + 1 < a.length && 56320 == (a.charCodeAt(g + 1) & 64512) ? (l = 65536 + ((l & 1023) << 10) + (a.charCodeAt(++g) & 1023), e[f++] = l >> 18 | 240, e[f++] = l >> 12 & 63 | 128) : e[f++] = l >> 12 | 224, e[f++] = l >> 6 & 63 | 128), e[f++] = l & 63 | 128)
    }
    a = b;
    for (f = 0; f < e.length; f++)
        a += e[f], a = hk(a, "+-a^+6");
    a = hk(a, "+-3^+b+-f");
    a ^= Number(d[1]) || 0;
    0 > a && (a = (a & 2147483647) + 2147483648);
    a %= 1E6;
    return c + (a.toString() + "." +
    (a ^ b))
};

VBA代码如下：

Function GoogleTranslate(strWord As String, Optional Mode As Boolean = False) As String
    'Mode为TRUE则为汉译英，为FALSE则为英译汉，默认是FALSE
    Dim strURL As String
    Dim strText As String
    Dim strJSScript As String
    Dim objHTTP As Object
    Dim TKKFunc As String
    Dim OtherFunc As String
    Dim objHTML As Object
    Dim DataFunc As String
    Dim tkValue As String
    Dim EncodeWord As String
    Dim strMode As String
    
    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set objHTML = CreateObject("htmlfile")
    
    '获取TKK函数
    strURL = "http://translate.google.cn/"
    strText = GetReponseText(objHTTP, strURL)
    TKKFunc = "TKK=" & Split(Split(strText, "TKK=")(1), "');")(0) & "');"
    
    '获取其他函数
    strURL = "http://translate.google.cn/translate/releases/twsfe_20161212_RC00/r/js/desktop_module_main.js"
    strText = GetReponseText(objHTTP, strURL)
    OtherFunc = "var gk=" & Split(Split(strText, "var gk=")(1), "var kk=")(0)
    
    '合成完整的tk算法函数，并加上html代码：
    strJSScript = "<html><script>" & TKKFunc & OtherFunc & "</script></html>"
    
    '计算单词的tk值
    objHTML.write strJSScript
    tkValue = CallByName(objHTML.parentwindow, "jk", VbMethod, strWord)
    
    '将单词进行编码
    EncodeWord = CallByName(objHTML.parentwindow, "encodeURIComponent", VbMethod, strWord)
    
    '从服务器获取翻译数据
    If Mode Then
        strMode = "&sl=zh-CN&tl=en"
    Else
        strMode = "&sl=en&tl=zh-CN"
    End If
    strURL = "http://translate.google.cn/translate_a/single?client=t" _
        & strMode & "&hl=zh-CN" _
        & "&dt=at&dt=bd&dt=ex&dt=ld&dt=md&dt=qca&dt=rw&dt=rm&dt=ss&dt=t" _
        & "&ie=UTF-8&oe=UTF-8&source=bh&ssel=0&tsel=0&kc=1" _
        & tkValue _
        & "&q=" & EncodeWord
    strText = GetReponseText(objHTTP, strURL)
    
    '自定义处理数据的js函数
    DataFunc = "getdata=function(a){var s='';a=eval(a);for(var i=0;i<a[0].length-1;i++)s+=a[0][i][0];return s}"
    strJSScript = "<html><script>" & DataFunc & "</script></html>"
    
    '获取翻译
    objHTML.write strJSScript
    GoogleTranslate = CallByName(objHTML.parentwindow, "getdata", VbMethod, strText)
    
    Set objHTTP = Nothing
    Set objHTML = Nothing
End Function

Private Function GetReponseText(objHTTP As Object, strURL As String)
    With objHTTP
        .Open "GET", strURL, False
        .setRequestHeader "User-Agent", "Mozilla/4.0"
        .Send
        GetReponseText = .responsetext
    End With
End Function