web-dev-qa-db-ja.com

VBAを使用してテキストを翻訳する

おそらく珍しい請願かもしれませんが、ここに問題があります。

サードパーティのExcelを自分の組織に採用しています。 Excelは英語で開発されており、私の組織の人々はスペイン語を話します。元のワークシートとまったく同じコードを使用したいのですが、触れない方がいい（できます）ので、メッセージボックスが表示されるたびに（テキストは英語で）関数を使用したい、私はmsgboxメッセージを翻訳しますが、元のスクリプトには触れません。元のコードでmsgboxが呼び出されるたびに呼び出すことができるマスクを探しています。

サードパーティの開発者は頻繁にコードを変更する可能性があるため、元のコードには触れないことをお勧めします。コードを少しでも変更するたびにコードを変更するのは非常に面倒です。

それは可能ですか？

excelvbagoogle-translatemsgbox
11
MariPlaza

どうぞ。

  Sub test()
    Dim s As String
    s = "hello world"
    MsgBox transalte_using_vba(s)

End Sub



 Function transalte_using_vba(str) As String
' Tools Refrence Select Microsoft internet Control


    Dim IE As Object, i As Long
    Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String, CLEAN_DATA

    Set IE = CreateObject("InternetExplorer.application")
    '   TO CHOOSE INPUT LANGUAGE

    inputstring = "auto"

    '   TO CHOOSE OUTPUT LANGUAGE

    outputstring = "es"

    text_to_convert = str

    'open website

    IE.Visible = False
    IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    Application.Wait (Now + TimeValue("0:00:5"))

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    CLEAN_DATA = Split(Application.WorksheetFunction.Substitute(IE.Document.getElementById("result_box").innerHTML, "</SPAN>", ""), "<")

    For j = LBound(CLEAN_DATA) To UBound(CLEAN_DATA)
        result_data = result_data & Right(CLEAN_DATA(j), Len(CLEAN_DATA(j)) - InStr(CLEAN_DATA(j), ">"))
    Next


    IE.Quit
    transalte_using_vba = result_data


End Function
17
Santosh

これが私のやり方です。これは、Google翻訳で使用される言語コードを指すオプションの列挙オブジェクトを持つ関数です。簡単にするために、いくつかの言語コードのみを含めました。また、このサンプルでは、​​Microsoft Internet Controlsリファレンスを選択したため、オブジェクトを作成する代わりに、InternetExplorerオブジェクトを使用しています。そして最後に、出力をクリーンアップする必要をなくすために、.innerHTMLではなく.innerTextを使用しました。覚えておいてください、グーグル翻訳では約3000程度の文字制限があります。また、特にこれを複数回使用する場合は、IE = nothingを設定する必要があります。そうでない場合、複数のIEを作成します。 =プロセス、最終的には機能しなくなります。

セットアップ...

Option Explicit

Const langCode = ("auto,en,fr,es")

Public Enum LanguageCode
    InputAuto = 0
    InputEnglish = 1
    InputFrench = 2
    InputSpanish = 3
End Enum

Public Enum LanguageCode2
    ReturnEnglish = 1
    ReturnFrench = 2
    ReturnSpanish = 3
End Enum

テスト...

Sub Test()

Dim msg As String

msg = "Hello World!"

MsgBox AutoTranslate(msg, InputEnglish, ReturnSpanish)

End Sub

関数...

Public Function AutoTranslate(ByVal Text As String, Optional LanguageFrom As LanguageCode, Optional LanguageTo As LanguageCode2) As String

Dim langFrom As String, langTo As String, IE As InternetExplorer, URL As String, myArray

If IsMissing(LanguageFrom) Then
    LanguageFrom = InputAuto
End If
If IsMissing(LanguageTo) Then
    LanguageTo = ReturnEnglish
End If

myArray = Split(langCode, ",")
langFrom = myArray(LanguageFrom)
langTo = myArray(LanguageTo)

URL = "https://translate.google.com/#" & langFrom & "/" & langTo & "/" & Text

Set IE = New InternetExplorer

IE.Visible = False
IE.Navigate URL

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    Application.Wait (Now + TimeValue("0:00:5"))

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    AutoTranslate = IE.Document.getElementByID("result_box").innerText

    IE.Quit

    Set IE = Nothing


End Function
5
Josh

Google Translation APIを使用する最新のソリューションの1つGoogle Translation APIを有効にするには、最初にプロジェクトと認証情報を作成する必要があります。 403（1日の上限）を受け取った場合は、Google Cloudアカウントに支払い方法を追加する必要があります。そうすれば、すぐに結果が得られます。

Private Function GoogleTranslateJ(ByVal text, ByVal resLang, ByVal srcLang) As String
Dim jsonProvider As Object

Dim jsonResult As Object
Dim jsonResultText As String

Dim googleApiUrl As String
Dim googleApiKey As String

Dim resultText As String

Set jsonProvider = CreateObject("MSXML2.ServerXMLHTTP")

text = Replace(text, " ", "%20")
googleApiKey = "ijHF28h283fjijefiwjeofij90f2h923" 'YOUR GOOGLE API KEY

googleApiUrl = "https://translation.googleapis.com/language/translate/v2?key=" & googleApiKey & "&source=" & srcLang & "&target=" & resLang & "&q=" & text

jsonProvider.Open "POST", googleApiUrl, False
jsonProvider.setRequestHeader "Content-type", "application/text"
jsonProvider.send ("")
jsonResultText = jsonProvider.responseText

Set jsonResult = JsonConverter.ParseJson(jsonResultText)
Set jsonResult = jsonResult("data")
Set jsonResult = jsonResult("translations")
Set jsonResult = jsonResult(1)

resultText = jsonResult("translatedText")

GoogleTranslateJ = resultText
End Function
4
Vitalii Ivanov

更新：_For Each v In arr_Response_- iterationを改善し、特殊文字を許可しました。翻訳処理中のマウスカーソルの変更を追加しました。翻訳されたoutput_stringを改善する方法の例を追加しました。

他にも無料の翻訳APIの大部分がありますが、Googleの翻訳サービスであるGTS（私の意見では）に勝るものはありません。無料のGTS使用に対するGoogleの制限の結果として、最高のVBAアプローチはIE.navigationに絞り込まれているようです-Santoshの回答も強調しています。

このアプローチを使用すると、いくつかの問題が発生します。 IE-instansは、ページが完全に読み込まれるタイミングを認識していません。また、IE.ReadyStateは実際には信頼できません。したがって、コーダーは_Application.Wait_関数を使用して「遅延」を追加する必要があります。この関数を使用する場合、ページが完全にロードされるまでにかかる時間を推測しているだけです。インターネットが本当に遅い状況では、このハードコードされた時間は十分ではないかもしれません。次のコードは、EnhancedReadyStateを使用してこれを修正します。

シートに異なる列があり、すべてのセルに異なる翻訳を追加したい状況では、式内からVBA関数を呼び出すのではなく、translation-stringがClipBoardに割り当てられる最善の方法を見つけます。これにより、翻訳を簡単に貼り付け、文字列として変更できます。

Columns in Excel

使用方法：

  1. プロシージャをカスタムVBAモジュールに挿入する
  2. 4つの定数をあなたの欲望に変えてください（上のTranslationTextを参照）
  3. TranslationText- procedureを起動するためのショートキーを割り当てます

Shortkey Excel

  1. 翻訳するセルをアクティブ化します。言語タグで終了する最初の行が必要でした。 「_da」、「_ en」、「_ de」など。別の機能が必要な場合は、ws_ActiveWS.Cells(r_ActiveCell.Row, r_InputRange.Column)を変更します

enter image description here

  1. 4.からショートキーを押します（CTRL + SHIRT + Sなど）。プロセスバー（Excelの下部）でプロセスを確認します。変換が表示されたら貼り付け（CTRL + V）：

enter image description hereTranslation done

_    Option Explicit

    'Description: Translates content, and put the translation into ClipBoard
    'Required References: MIS (Microsoft Internet Control)
    Sub TranslateText()

    'Change Const's to your desire
    Const INPUT_RANGE As String = "table_products[productname_da]"
    Const INPUT_LANG As String = "da"
    Const PROCESSBAR_INIT_TEXT As String = "Processing translation. Please wait... "
    Const PROCESSBAR_DONE_TEXT As String = "Translation done. "

    Dim ws_ActiveWS As Worksheet
    Dim r_ActiveCell As Range, r_InputRange As Range
    Dim s_InputStr As String, s_InputLang As String, s_OutputLang As String, arr_Response() As String, s_Translation As String
    Dim o_IE As Object, o_MSForms_DataObject As Object
    Dim i As Long
    Dim v As Variant

    Set o_MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set ws_ActiveWS = ThisWorkbook.ActiveSheet
    Set r_ActiveCell = ActiveCell
    Set o_IE = CreateObject("InternetExplorer.Application")
    Set r_InputRange = ws_ActiveWS.Range(INPUT_RANGE)

    'Update statusbar ("Processing translation"), and change cursor
    Application.Statusbar = PROCESSBAR_INIT_TEXT
    Application.Cursor = xlWait

    'Declare inputstring (The string you want to translate from)
    s_InputStr = ws_ActiveWS.Cells(r_ActiveCell.Row, r_InputRange.Column)

    'Find the output-language
    s_OutputLang = Right(ws_ActiveWS.Cells(1, r_ActiveCell.Column).Value, 2)

    'Navigate to translate.google.com
    With o_IE

        .Visible = False 'Run IE in background
        .Navigate "http://translate.google.com/#" & INPUT_LANG & "/" _
            & s_OutputLang & "/" & s_InputStr

        'Call improved IE.ReadyState
        Do
            ImprovedReadyState
        Loop Until Not .Busy

        'Split the responseText from Google
        arr_Response = Split(.Document.getElementById("result_box").innerHTML, "<span class")

        'Remove html from response, and construct full-translation-string
        For Each v In arr_Response
            s_Translation = s_Translation & Replace(v, "<span>", "")
            s_Translation = Replace(s_Translation, "</span>", "")
            s_Translation = Replace(s_Translation, """", "")
            s_Translation = Replace(s_Translation, "=hps>", "")
            s_Translation = Replace(s_Translation, "=atn>", "")
            s_Translation = Replace(s_Translation, "=hps atn>", "")

            'Improve translation.
            'This could etc. be moved to seperate sheets (containing every language), and make the lookup in a dynamic table/sheet. Futurely it'd be possible to hook on the changeevent, and automatically improve the translation-algoritmen.
            'If Google can't translate the etc. the Word "Lys", you can extend the translation, with an auto correction. This example shows to autocorrect the Word "Lys" -> "ljus". 
            If (s_OutputLang = "sv") Then
                s_Translation = Replace(s_Translation, "lys", "ljus")
            End if
        Next v

        'Put Translation into Clipboard
        o_MSForms_DataObject.SetText s_Translation
        o_MSForms_DataObject.PutInClipboard

        If (s_Translation <> vbNullString) Then
            'Put Translation into Clipboard
            o_MSForms_DataObject.SetText s_Translation
            o_MSForms_DataObject.PutInClipboard

            'Update statusbar ("Translation done"). If the input_string is above 70 chars (which is roughly the limitation in processbar), then cut the string, and extend with "...".
            Application.Statusbar = PROCESSBAR_DONE_TEXT & """" & IIf(Len(s_InputStr) < 70, s_InputStr, Mid(s_InputStr, 1, 70) & "...") & """"
        Else
            'Update statusbar ("Error")
            Application.Statusbar = PROCESSBAR_ERROR_TEXT
        End If

        'Cleanup
        .Quit

        'Change cursor back to default
        Application.Cursor = xlDefault

        Set o_MSForms_DataObject = Nothing
        Set ws_ActiveWS = Nothing
        Set r_ActiveCell = Nothing
        Set o_IE = Nothing

    End With

End Sub

Sub ImprovedReadyState()

    Dim si_PauseTime As Single: si_PauseTime = 1 'Set duration
    Dim si_Start As Single: si_Start = Timer 'Set start-time
    Dim si_Finish As Single 'Set end-time
    Dim si_TotalTime As Single 'Calculate total time.

    Do While Timer < (si_Start + si_PauseTime)
        DoEvents
    Loop

    si_Finish = Timer

    si_TotalTime = (si_Finish - si_Start)

End Sub
_
2
Unicco

Uniccoが投稿した答えは素晴らしいです！

テーブルの要素を削除して単一のセルで機能させましたが、結果は同じです。

私が翻訳したテキストの一部（製造コンテキストの操作手順）を使用すると、追加の<"span">構造を使用して、Googleが時々返信文字列にがらくたを追加し、時には応答を倍にします。

「次のv」の直後のコードに次の行を追加しました。

s_Translation = RemoveSpan(s_Translation & "")

そして、この関数を作成しました（同じモジュールに追加）：

Private Function RemoveSpan(Optional InputString As String = "") As String

Dim sVal As String
Dim iStart As Integer
Dim iEnd As Integer
Dim iC As Integer
Dim iL As Integer

If InputString = "" Then
    RemoveSpan = ""
    Exit Function
End If

sVal = InputString

' Look for a "<span"
iStart = InStr(1, sVal, "<span")

Do While iStart > 0 ' there is a "<span"
    iL = Len(sVal)
    For iC = iStart + 5 To iL
        If Mid(sVal, iC, 1) = ">" Then Exit For ' look for the first ">" following the "<span"
    Next
    If iC < iL Then ' then we found a "<"
        If iStart > 1 Then ' the "<span" was not in the beginning of the string
            sVal = Left(sVal, iStart - 1) & Right(sVal, iL - iC) ' grab to the left of the "<span" and to the right of the ">"
        Else ' the "<span" was at the beginning
            sVal = Right(sVal, iL - iC) ' grap to the right of the ">"
        End If
    End If
    iStart = InStr(1, sVal, "<span") ' look for another "<span"
Loop
    RemoveSpan = sVal
End Function

振り返ってみると、これをもっと効率的に行うことができたのに気づきましたが、それは機能し、次に進んでいます！

0
Todd