GoogleとYahoo!で同時に翻訳するWordマクロ

ホーム
Word, Google関連, 翻訳サービス関連
GoogleとYahoo!で同時に翻訳するWordマクロ

2012.05.20

GoogleとYahoo!で同時に翻訳するWordマクロ

「Google翻訳で文字列を翻訳するマクロ」と「Yahoo!翻訳で文字列を翻訳するマクロ」の2つを利用して、Google翻訳とYahoo!翻訳で同時に翻訳を行うWordマクロを作成してみました。
結果は新しい文書に表示されます。

※ 下記マクロはGoogle翻訳とYahoo!翻訳の仕様に依存します。急な仕様変更によって下記マクロが動作しなくなる可能性がありますので、その点はご注意ください。

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の開発メインスタッフとなる。"
  
  CompareTranslateWebService s '日本語から英語
  CreateObject("WScript.Shell").Popup "処理が終了しました。", , , 64
End Sub

Private Sub CompareTranslateWebService(ByVal target As String, Optional ByVal FromLng As String = "ja", Optional ByVal ToLng As String = "en")
'翻訳結果を比較
  Dim wapp As Object
  Dim doc1 As Object, doc2 As Object
  Dim ret As String
  Const Cap1 As String = "■ Yahoo!翻訳結果"
  Const Cap2 As String = "■ Google翻訳結果"
  
  '実行前チェック(Yahoo!翻訳に合わせる)
  '文字数チェック(4,000文字まで)
  If Len(target) >= 4000 Then
    MsgBox "翻訳対象の文字数が多過ぎます。" & vbCrLf & "翻訳可能な文字数は4,000文字までです。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  '対応言語チェック
  FromLng = LCase$(FromLng)
  Select Case FromLng
    Case "en", "zh", "ko", "fr", "de", "es", "pt", "it", "ja"
    Case Else
      MsgBox "未対応の翻訳元言語です。", vbCritical + vbSystemModal
      Exit Sub
  End Select
  ToLng = LCase$(ToLng)
  Select Case ToLng
    Case "en", "zh", "ko", "fr", "de", "es", "pt", "it", "ja"
    Case Else
      MsgBox "未対応の翻訳先言語です。", vbCritical + vbSystemModal
      Exit Sub
  End Select
  
  '結果表示用Word起動
  Set wapp = CreateObject("Word.Application")
  wapp.Visible = True
  
  'Yahoo!翻訳実行
  ret = TranslateYahoo(target, FromLng, ToLng)
  Set doc1 = wapp.Documents.Add
  doc1.Range.InsertAfter Cap1 & vbCrLf & vbCrLf
  With doc1.Range(0, Len(Cap1)).Font
    .Size = 12
    .Bold = True
  End With
  doc1.Range.InsertAfter ret
  
  'Google翻訳実行
  '中国語パラメータ対応
  Select Case FromLng
    Case "zh": FromLng = "zh-CN"
  End Select
  Select Case ToLng
    Case "zh": ToLng = "zh-CN"
  End Select
  ret = "" '初期化
  ret = TranslateGoogle(target, FromLng, ToLng)
  Set doc2 = wapp.Documents.Add
  doc2.Range.InsertAfter Cap2 & vbCrLf & vbCrLf
  With doc2.Range(0, Len(Cap2)).Font
    .Size = 12
    .Bold = True
  End With
  doc2.Range.InsertAfter ret
    
  '結果を並べて表示
  wapp.Windows.Arrange wdTiled
  wapp.WindowState = wdWindowStateMinimize
  wapp.WindowState = wdWindowStateNormal
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 TranslateYahoo(ByVal target As String, Optional ByVal FromLng As String = "auto", Optional ByVal ToLng As String = "en") As String
  Dim dat As Variant
  Dim js As String
  Dim ret As String
  Dim url As String
  Dim crumb As String
  Dim itm As Object
  Dim cnt As Long
  Dim ResultSet, ResultText, Results, key, TranslatedText '表示用ダミー
  
  ret = "" '初期化
  '文字数チェック(4,000文字まで)
  If Len(target) >= 4000 Then
    MsgBox "翻訳対象の文字数が多過ぎます。" & vbCrLf & "翻訳可能な文字数は4,000文字までです。", vbExclamation + vbSystemModal
    GoTo Err:
  End If
  '対応言語チェック
  FromLng = LCase$(FromLng)
  Select Case FromLng
    Case "auto"
      FromLng = GetPredictLanguage(target)
      If Len(Trim$(FromLng)) < 1 Then
        MsgBox "翻訳元言語の自動判定に失敗しました。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
        GoTo Err:
      End If
    Case "en", "zh", "ko", "fr", "de", "es", "pt", "it", "ja"
    Case Else
      MsgBox "未対応の翻訳元言語です。", vbCritical + vbSystemModal
      GoTo Err:
  End Select
  ToLng = LCase$(ToLng)
  Select Case ToLng
    Case "en", "zh", "ko", "fr", "de", "es", "pt", "it", "ja"
    Case Else
      MsgBox "未対応の翻訳先言語です。", vbCritical + vbSystemModal
      GoTo Err:
  End Select
  
  crumb = "" '初期化
  crumb = GetCrumb()
  If Len(Trim$(crumb)) < 1 Then
    MsgBox "crumbの取得に失敗しました。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    GoTo Err:
  End If
  
  js = "": cnt = 1 '初期化
  url = "http://honyaku.yahoo.co.jp/TranslationText"
  dat = "ieid=" & FromLng & "&oeid=" & ToLng & "&output=json&_crumb=" & crumb & "&p=" & 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"
      For Each itm In .CodeObject.eval(js).ResultSet.ResultText.Results
        If cnt = 1 Then
          ret = ret & itm.TranslatedText
        Else
          ret = ret & vbCrLf & vbCrLf & itm.TranslatedText
        End If
        cnt = cnt + 1
      Next
    End With
  End If
  
Err:
  TranslateYahoo = ret
End Function

Private Function GetCrumb() As String
'TTcrumbの値取得
  Dim ret As String
  Dim crumb As String
  Dim v As Variant
  
  crumb = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "http://honyaku.yahoo.co.jp/transtext/", False
    .Send
    If .Status = 200 Then ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) > 0 Then
    With CreateObject("VBScript.RegExp")
      .IgnoreCase = True
      .Global = True
      .Pattern = "id=""TTcrumb"".*(?=""/>)"
      If .Test(ret) Then
        v = Split(.Execute(ret)(0), """")
        crumb = v(UBound(v))
      End If
    End With
  End If
  GetCrumb = crumb
End Function

Private Function GetPredictLanguage(ByVal target As String)
'言語自動判定結果取得
  Dim d As Object
  Dim ret As String
  Dim url As String
  
  ret = "": Set d = Nothing '初期化
  'url="http://honyaku.yahoo.co.jp/LangClassifyService/V1/predict_prob?output=json&query="
  url = "http://honyaku.yahoo.co.jp/LangClassifyService/V1/predict_prob?query=" & EncodeURL(target)
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .Send
    If .Status = 200 Then Set d = .responseXML
  End With
  If Not d Is Nothing Then
    ret = d.SelectSingleNode("/ResultSet/Predict").Text
  End If
  On Error GoTo 0
  GetPredictLanguage = 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