VBA：Google翻译（含tk算法）

完整的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=")(), "');")() & "');"

    '获取其他函数

    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=")(), "var kk=")()

    '合成完整的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

巴特西

VBA：Google翻译（含tk算法）

最新文章

热门文章