Google翻訳で文字列を翻訳するマクロ

ホーム
Office関連, Excel, Word, Google関連, 翻訳サービス関連
Google翻訳で文字列を翻訳するマクロ

Office関連

2012.02.15

Google翻訳で文字列を翻訳するマクロ

※ 2016/2 時点では下記の方法はもう使用できなくなっています。VBAからGoogle翻訳を利用する場合は有償のTranslate APIをお使いください。

2016/2/18 追記：
Microsoft Translator APIをVBAから呼び出すコードについて記事を書きました。

・Microsoft Translator APIで文字列を翻訳するVBAマクロ
//www.ka-net.org/blog/?p=6697

以前書いた記事「Google翻訳の言語自動検出機能を追う」でGoogle翻訳の言語を自動的に検出する仕組みについて調べてみましたが、今回は検出された言語以外の部分に着目してみます。

まずは翻訳にかけたときのHTTPヘッダを改めて確認してみると下記のようになっていました。

POST /translate_a/t HTTP/1.1
Host: translate.google.co.jp
Content-Type: application/x-www-form-urlencoded;charset=utf-8
client=t&text=%5B%E6%8C%BF%E5%85%A5%5D%20%E3%82%BF%E3%83…&hl=ja&sl=auto&tl=en&multires=1&prev=conf&psl=ja&ptl=en…

「Google翻訳の言語自動検出機能を追う」のときは短文を翻訳にかけたのでGETになっていましたが、今回は長文でテストしたのでPOSTになっています。
そして返ってきた結果(responseText)が下記になります。

[[["The gallery of the Insert tab , which contains the items…]],[[0,5],[21,22]],""]],,,[["ja"]],7]

上記結果を見ると以前調べたときと同様の形で返ってきていることが分かります。
であれば、POSTするパラメータ「client」の値を「t」以外にすれば扱いやすいJSON形式で返ってくるはずなので、早速試してみました。

{"sentences":[{"trans":"The gallery of the Insert tab, which contains the items…, "translit":"","src_translit":"Bunsho no teisai o genzai no tenpur?to o hozon shimasu."}],"src":"ja","server_time":497}

予想通りの結果です。
以前はこの結果から”検出された言語“を示しているであろう「src」を利用したのですが、配列”sentences“にあるtransやtranslitを利用すれば、訳文や音訳を得ることができそうです。

この「trans」を利用してGoogle翻訳で翻訳を行うマクロを早速書いてみました。

Option Explicit
 
Public Sub Sample()
  Dim s As String
   
  'テスト用文字列は http://ja.wikipedia.org/wiki/Microsoft より
  s = "当初は世に登場して間もない8ビットのマイクロプロセッサを搭載したコンピュータ「アルテア (Altair)」上で動く、BASICインタプリタの開発・販売で成功を収めた。" & vbCrLf
  s = s & "当初はネイティブ環境（カセットテープベースでオペレーティングシステムはなくROM-BASICに近い環境のもの）だったが、CP/Mが標準プラットフォームとなると、CP/MベースのMBASICを発表する。グラフィックス機能をつけたGBASIC、16ビット用のGWBASICが登場する。なお、GWのWは16ビットを意味するダブルバイト/ワードだとされている。" & vbCrLf
  s = s & "ついでIBM PC上のオペレーティングシステムの開発を請け負い、シアトルコンピュータプロダクツの86-DOSの権利を購入し改良、PC DOS（自社ブランドでMS-DOS）を開発。IBM PCとそれら互換機の普及と共にオペレーティングシステムの需要も伸び、現在に至る地固めを確かなものとした。86-DOSの開発者ティム・パターソンは後にマイクロソフトに引き抜かれMS-DOSの開発メインスタッフとなる。"
   
  With CreateObject("WScript.Shell")
    .Popup TranslateGoogle(s) '言語自動検出から英語(デフォルト)
    .Popup TranslateGoogle(s, , "th") '言語自動検出からタイ語
    .Popup TranslateGoogle(s, "ja", "ar") '日本語からアラビア語
  End With
   
  'テスト用文字列は http://en.wikipedia.org/wiki/Microsoft より
  s = "Microsoft Corporation (NASDAQ: MSFT) is an American multinational corporation headquartered in Redmond, Washington, United States that develops, manufactures, licenses, and supports a wide range of products and services predominantly related to computing through its various product divisions." & vbCrLf
  s = s & "Established on April 4, 1975 to develop and sell BASIC interpreters for the Altair 8800, Microsoft rose to dominate the home computer operating system market with MS-DOS in the mid-1980s, followed by the Microsoft Windows line of operating systems." & vbCrLf
  s = s & "Microsoft would also come to dominate the office suite market with Microsoft Office."
   
  With CreateObject("WScript.Shell")
    .Popup TranslateGoogle(s, , "ja") '言語自動検出から日本語
    .Popup TranslateGoogle(s, "en", "ta") '英語からタミル語
    .Popup TranslateGoogle(s, "en", "zh-CN") '英語から簡体中国語
  End With
End Sub
 
Private Function TranslateGoogle(ByVal target As String, Optional ByVal FromLng As String = "auto", Optional ByVal ToLng As String = "en") As String
  Dim dat As Variant
  Dim ret As String
  Dim js As String
  Dim itm As Object
  Dim cnt As Long
  Dim sentences, length '小文字表示用ダミー
  Const url As String = "http://translate.google.com/translate_a/t"
   
  ret = "": js = "": cnt = 1 '初期化
  dat = "client=0&sl=" & FromLng & "&tl=" & ToLng & "&text=" & EncodeURL(target)
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send dat
    If .Status = 200 Then js = .responseText
  End With
  On Error GoTo 0
  If Len(js) > 0 Then
    js = "(" & js & ")"
    With CreateObject("ScriptControl")
      .Language = "JScript"
      'Debug.Print .CodeObject.eval(js).sentences.length
      For Each itm In .CodeObject.eval(js).sentences
        If cnt = 1 Then
          ret = ret & itm.trans
        Else
          ret = ret & vbCrLf & itm.trans
        End If
        cnt = cnt + 1
      Next
    End With
  End If
  TranslateGoogle = ret
End Function
 
Private Function EncodeURL(ByVal sWord As String) As String
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(sWord)
  End With
End Function