「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
この記事へのコメントはありません。