「Google翻訳で文字列を翻訳するマクロ」ではGoogle翻訳を利用したマクロについて書きましたが、今回はGoogleではなくYahoo!翻訳を利用したマクロを作成してみました。

Option Explicit

Public Sub Sample()
  Dim target As String
  Dim ret As String
  
  'テスト用文字列は http://ja.wikipedia.org/wiki/%E3%83%9E%E3%82%A4%E3%82%AF%E3%83%AD%E3%82%BD%E3%83%95%E3%83%88 より
  target = "マイクロソフト（Microsoft Corporation）は、アメリカ合衆国に本社を置く世界最大のコンピュータ・ソフトウェア会社。" & vbCrLf
  target = target & "現在ではインターネット事業を手がけ、スマートフォン、ハードウェア、ゲーム機器も製造している。" & vbCrLf
  target = target & "1975年4月4日にビル・ゲイツとポール・アレンらによって設立された。"
  ret = TranslateYahoo(target, "ja", "zh") '日本語から中国語
  If Len(ret) > 0 Then
    CreateObject("WScript.Shell").Popup ret
  End If
End Sub

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 '表示用ダミー
  
  '********************************************************************
  '■ 対応する言語(引数FromLng,ToLng) http://honyaku.yahoo.co.jp/ より
  '   自動検出:auto(FromLngのみ)
  '   日本語:ja
  '   英語:en
  '   中国語:zh
  '   韓国語:ko
  '   フランス語:fr
  '   ドイツ語:de
  '   スペイン語:es
  '   ポルトガル語:pt
  '   イタリア語:it
  '********************************************************************
  
  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 & 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

翻訳対象の文字列と元の言語、翻訳する言語を引数として渡すと、Yahoo!翻訳で翻訳した結果を返すマクロとなっています。