EXCEL VBAにて動作する翻訳サンプルログラムを探していましたら、HN:きぬあさ(きぬよ&あさみ)管理人様の素晴らしいサイトを発見しました。
就きましては、若干ですが自分なりにアレンジしたソースプログラムをご紹介致します。

◆共通プログラム

Private Sub CommandButtonOriginalCellValueClear_Click()
Sheet2.Range(“B3”).Value = “”
End Sub

Private Sub CommandButtonTanslationCellValueClear_Click()
Sheet2.Range(“B5”).Value = “”
End Sub

Private Function OptionButtonSelect(ByRef strOrg As String, ByRef strCov As String) As Boolean
If OptionButtonOrg_ja.Value Then
strOrg = “ja”
ElseIf OptionButtonOrg_en.Value Then
strOrg = “en”
ElseIf OptionButtonOrg_zh.Value Then
strOrg = “zh”
ElseIf OptionButtonOrg_ko.Value Then
strOrg = “ko”
ElseIf OptionButtonOrg_fr.Value Then
strOrg = “fr”
ElseIf OptionButtonOrg_de.Value Then
strOrg = “de”
ElseIf OptionButtonOrg_es.Value Then
strOrg = “es”
ElseIf OptionButtonOrg_pt.Value Then
strOrg = “pt”
ElseIf OptionButtonOrg_it.Value Then
strOrg = “it”

End If

If OptionButtonCov_ja.Value Then
strCov = “ja”
ElseIf OptionButtonCov_en.Value Then
strCov = “en”
ElseIf OptionButtonCov_zh.Value Then
strCov = “zh”
ElseIf OptionButtonCov_co.Value Then
strCov = “ko”
ElseIf OptionButtonCov_fr.Value Then
strCov = “fr”
ElseIf OptionButtonCov_de.Value Then
strCov = “de”
ElseIf OptionButtonCov_es.Value Then
strCov = “es”
ElseIf OptionButtonCov_pt.Value Then
strCov = “pt”
ElseIf OptionButtonCov_it.Value Then
strCov = “it”

End If
If strOrg = strCov Then
MsgBox “同国語の翻訳は出来ません。”, vbExclamation, “選択エラー”
OptionButtonSelect = False
Else
OptionButtonSelect = True
End If

End Function

◆Google翻訳サンプルプログラム

Private Sub CommandButtonGoogleTrans_Click()
Dim target As String
Dim ret As String
Dim strOrg As String
Dim strCov As String
If OptionButtonSelect(strOrg, strCov) Then
With Sheet2
.Range(“B5”) = “”
target = .Range(“B3”)
End With
ret = TranslateGoogle(target, strOrg, strCov)
If Len(ret) > 0 Then

Sheet2.Range(“B5”) = ret

End If
End If

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=” & EncodeURL2(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”)

js = “(” & js & “)”
With CreateObject(“ScriptControl”)
.Language = “JScript”
ret = .CodeObject.eval(js) ‘.src
End With
End With
End If
TranslateGoogle = ret
End Function

Private Function EncodeURL2(ByVal sWord As String) As String
With CreateObject(“ScriptControl”)
.Language = “JScript”
EncodeURL2 = .CodeObject.encodeURIComponent(sWord)
End With
End Function

◆Yahoo!翻訳サンプルプログラム

Private Sub CommandButtonTranslation_Click()
Dim target As String
Dim ret As String
Dim strOrg As String
Dim strCov As String

If OptionButtonSelect(strOrg, strCov) Then
With Sheet2
.Range(“B5”) = “”
target = .Range(“B3”)
End With
ret = TranslateYahoo(target, strOrg, strCov) ‘英語から日本語
If Len(ret) > 0 Then

Sheet2.Range(“B5”) = ret

End If
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

‘ .Open “GET”, “http://translate.google.com/translate_a/t”, 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