EXCEL VBA调用百度API翻译
Public Function translateZh_En(ByVal str As String) As String
'调用百度翻译API，将指定内容由中文翻译为英文
Dim par As String
Dim data() As String
par = generateReqStr(str, "zh", "en")
data() = translateJson(getHttp(par)) '调用API,获取API 返回, '调用JSON转换函数，解析API返回的结果
' Debug.Print data(0)
' Debug.Print data(1)
' Debug.Print data(2)
' Debug.Print data(3)
' Debug.Print data(4)
' Debug.Print data(5)
translateZh_En = UCase(data(3)) '获取API返回的翻译结果
End Function
Public Function translateZh_En_Batch(ByRef arr() As String) As String()
'调用百度翻译API，将指定内容由中文翻译为英文
Dim par As String
Dim data() As String
Dim returnData() As String
Dim resp As String
par = generateReqStrBatch(arr, "zh", "en")
resp = getHttp(par) '调用API,获取API 返回
data() = translateJsonBatch(resp) '调用JSON转换函数，解析API返回的结果
ReDim returnData(UBound(data) - 4) As String
For i = 0 To UBound(data) - 4
returnData(i) = UCase(Split(data(i), "|", -1, vbTextCompare)(1))
Next
translateZh_En_Batch = returnData() '获取API返回的翻译结果
End Function
Public Function translateEn_Zh(ByVal str As String) As String
'调用百度翻译API，将指定内容由英文翻译为中文
Dim par As String
Dim data() As String
par = generateReqStr(str, "en", "zh")
data() = translateJson(getHttp(par)) '调用API,获取API 返回, '调用JSON转换函数，解析API返回的结果
translateEn_Zh = data(3)
End Function
Public Function translateEn_Zh_Batch(ByRef arr() As String) As String()
'调用百度翻译API，将指定内容由英文翻译为中文
Dim par As String
Dim data() As String
Dim returnData() As String
Dim resp As String
par = generateReqStrBatch(arr, "en", "zh")
resp = getHttp(par) '调用API,获取API 返回
data() = translateJsonBatch(resp) '调用JSON转换函数，解析API返回的结果
ReDim returnData(UBound(data) - 4) As String
For i = 0 To UBound(data) - 4
returnData(i) = Split(data(i), "|", -1, vbTextCompare)(1)
Next
translateZh_En_Batch = returnData() '获取API返回的翻译结果
End Function
Public Function getHttpOld(str As String) As String
'调用API
Dim HttpReq As Object
Dim url As String
Set HttpReq = CreateObject("Microsoft.XMLHTTP") '创建XMLHTTP对象
url = "http://openapi.baidu.com/public/2.0/bmt/translate?client_id=iOMhRqTKNByhC80V9SbcQIpo&" & str
With HttpReq
.Open "GET", url, False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.SEND
'Debug.Print .responsetext
End With
'发送HTTL Get请求， 百度API只允许GET，不允许POST
getHttp = HttpReq.responsetext
End Function
Public Function getHttp(str As String) As String
'调用API（new）
Dim HttpReq As Object
Dim url As String
Set HttpReq = CreateObject("Microsoft.XMLHTTP") '创建XMLHTTP对象
url = "http://api.fanyi.baidu.com/api/trans/vip/translate?" & str
'Debug.Print (url)
With HttpReq
.Open "GET", url, False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.SEND
'Debug.Print .responsetext
End With
'发送HTTL Get请求， 百度API只允许GET，不允许POST
getHttp = HttpReq.responsetext
End Function
Public Function generateReqStr(q As String, from_Str As String, to_Str As String) As String
'生成Request 字符串
Dim appid As String
Dim key As String
Dim salt As Integer
Dim sign As String
Dim par As String
Math.Randomize (Timer)
salt = (Rnd * 1000000) Mod 20000
key = "修改为你自己申请的API的Key"
appid = "修改为你自己申请的API的appid"
'Debug.Print (appid + q + CStr(salt) + key)
sign = MD5_32(appid + q + CStr(salt) + key) '转换为MD5
'Debug.Print (sign)
par = "q=" + encode(q) + "&from=" + from_Str + "&to=" + to_Str + "&appid=" + appid + "&salt=" + CStr(salt) + "&sign=" + sign '调用urlencode 方法，将待翻译内容转换为urlencode,
generateReqStr = par
End Function
Public Function generateReqStrBatch(q() As String, from_Str As String, to_Str As String) As String
'生成Request 字符串
Dim appid As String
Dim key As String
Dim salt As Integer
Dim sign As String
Dim par As String
Dim str1 As String
'Dim ln As String
'ln = ChrB(10) & ChrB(0)
Math.Randomize (Timer)
salt = (Rnd * 1000000) Mod 20000
key = "修改为你自己申请的API的Key"
appid = "修改为你自己申请的API的appid"
For i = LBound(q) To UBound(q)
str1 = str1 & q(i) & vbLf
Next
'Debug.Print (appid + str1 + CStr(salt) + key)
sign = MD5_32(appid + str1 + CStr(salt) + key) '转换为MD5
'Debug.Print (sign)
par = "q=" + encode(str1) + "&from=" + from_Str + "&to=" + to_Str + "&appid=" + appid + "&salt=" + CStr(salt) + "&sign=" + sign '调用urlencode 方法，将待翻译内容转换为urlencode,
generateReqStrBatch = par
End Function
Public Function translateJson(str As String) As String()
'调用JScript 解析JSON
Dim js As Object
Dim objJSON As Object
Dim objJSON2 As Object
Dim strFunc As String
Dim returnData(6) As String
'创建Script对象
Set js = CreateObject("ScriptControl"): js.Language = "JScript"
'aa = "{""from"":""en"",""to"":""zh"",""trans_result"":[{""src"":""today"",""dst"":""\u4eca\u5929""}]}"
'获取第一层的数据内容的JavaScript函数代码
strFunc = "function getjson(s) { return eval('(' + s + ')'); }"
'获取第二层的数据内容JavaScript函数代码
strFunc2 = "function j(s) { return eval('(' + s + ').trans_result[0]'); }"
'将JavaScript函数代码加入到Script对象。
js.AddCode strFunc
js.AddCode strFunc2
Set objJSON = js.CodeObject.getjson(str) '执行函数方法 ,这是一种执行方法
On Error GoTo ErrorHandler1
Set objJSON2 = js.Run("j", str) '执行函数方法 ,这是另一种执行方法
'获取第一层的结果
'Debug.Print objJSON.from
'Debug.Print objJSON.to
'Debug.Print objJSON.trans_result
returnData(0) = objJSON.from
'returnData(1) = objJSON.To
'获取第二层的结果
'Debug.Print CallByName(objJSON2, "src", VbGet) '这是另一种获取属性的方法
'Debug.Print objJSON2.dst
returnData(2) = objJSON2.src
returnData(3) = objJSON2.dst
'如果API执行结果不正确，获取API的不正确的返回信息。
On Error GoTo ErrorHandler
returnData(4) = objJSON.error_code
returnData(5) = objJSON.error_msg
translateJson = returnData
Exit Function
ErrorHandler:
returnData(4) = ""
returnData(5) = ""
translateJson = returnData
Exit Function
ErrorHandler1:
returnData(0) = ""
returnData(1) = ""
returnData(2) = ""
returnData(3) = ""
returnData(4) = objJSON.error_code
returnData(5) = objJSON.error_msg
translateJson = returnData
Exit Function
End Function
Public Function translateJsonBatch(str As String) As String()
'调用JScript 解析JSON
Dim js As Object
Dim objJSON As Object
Dim objJSON2 As Object
Dim count As String
Dim count_i As Integer
Dim strFunc As String
Dim returnData(6) As String
Dim returnData2() As String
'创建Script对象
Set js = CreateObject("ScriptControl"): js.Language = "JScript"
'aa = "{""from"":""en"",""to"":""zh"",""trans_result"":[{""src"":""today"",""dst"":""\u4eca\u5929""}]}"
'获取第一层的数据内容的JavaScript函数代码
strFunc = "function getjson(s) { return eval('(' + s + ')'); }"
'获取第二层的数据个数JavaScript函数代码
strFunc1 = "function getjsonCount(s) { return eval('(' + s + ').trans_result.length'); }"
'获取第二层的数据内容JavaScript函数代码
strFunc2 = "function getjsonLevel(s,i) { return eval('(' + s + ').trans_result['+i+']'); }"
'将JavaScript函数代码加入到Script对象。
js.AddCode strFunc
js.AddCode strFunc1
js.AddCode strFunc2
On Error GoTo ErrorHandler2
Set objJSON = js.CodeObject.getjson(str) '执行函数方法 ,这是一种执行方法
On Error GoTo ErrorHandler1
count = js.CodeObject.getjsonCount(str) '获取数据个数
returnData(0) = objJSON.from
'returnData(1) = objJSON.To
count_i = Val(count)
If (count > 0) Then
ReDim returnData2(count + 3) As String
'Set objJSON2 = js.Run("j", str) '执行函数方法 ,这是另一种执行方法
returnData2(UBound(returnData2) - 3) = returnData(0)
returnData2(UBound(returnData2) - 2) = returnData(1)
For i = 0 To count - 1 '获取返回的数组内容
Set objJSON2 = js.CodeObject.getjsonLevel(str, i)
returnData(2) = objJSON2.src
returnData(3) = objJSON2.dst
returnData2(i) = returnData(2) & "|" & returnData(3)
Next
Else
ReDim returnData2(4) As String '无数据返回，则数据区域返回空
returnData2(0) = " | "
End If
'如果API执行结果不正确，获取API的不正确的返回信息。
On Error GoTo ErrorHandler
'returnData(4) = objJSON.error_code
'returnData(5) = objJSON.error_msg
returnData2(UBound(returnData2) - 1) = returnData(4)
returnData2(UBound(returnData2)) = returnData(5)
translateJsonBatch = returnData2
Exit Function
ErrorHandler:
'获取错误信息失败，则设置错误信息为空
returnData(4) = ""
returnData(5) = ""
returnData2(UBound(returnData2) - 1) = returnData(4)
returnData2(UBound(returnData2)) = returnData(5)
translateJsonBatch = returnData2
Exit Function
ErrorHandler1: '获取第一层数据失败，则返回错误信息
returnData(0) = ""
returnData(1) = ""
returnData(2) = ""
returnData(3) = ""
returnData(4) = objJSON.error_code
returnData(5) = objJSON.error_msg
ReDim returnData2(4) As String '无数据返回，则数据区域返回空
returnData2(UBound(returnData2) - 3) = returnData(0)
returnData2(UBound(returnData2) - 2) = returnData(1)
returnData2(UBound(returnData2) - 1) = returnData(4)
returnData2(UBound(returnData2)) = returnData(5)
returnData2(0) = " | "
translateJsonBatch = returnData2
Exit Function
ErrorHandler2: '获取第一层数据失败，则返回错误信息
ReDim returnData2(4) As String '无数据返回，则数据区域返回空
returnData2(0) = " | "
translateJsonBatch = returnData2
Exit Function
End Function
Public Function encode(ByVal str As String) As String
'调用JavaScript的encodeURIComponent方法进行urlencode 编码
Dim js As Object
Dim strFun As String
Dim data As String
Set js = CreateObject("ScriptControl"): js.Language = "JScript"
'aa = "{""from"":""en"",""to"":""zh"",""trans_result"":[{""src"":""today"",""dst"":""\u4eca\u5929""}]}"
strFunc = "function getjson(s) { return eval('encodeURIComponent(\""'+s+'\"")'); }"
js.AddCode strFunc
str = Replace(str, vbCrLf, "\r\n") '转换回车换行符为URL回车换行符
str = Replace(str, vbLf, "\n") '转换换行符为URL换行符
data = js.CodeObject.getjson(str)
'Debug.Print data
encode = data
End Function
Sub testTranslate()
Debug.Print translateZh_En("感觉身体被掏空")
Dim testData() As String
ReDim testData(5)
testData(0) = "苹果"
testData(1) = "香蕉"
testData(2) = "不作就不会死"
testData(3) = "红色"
testData(4) = "绿色"
testData(5) = "黄色"
Dim returnData() As String
returnData = translateZh_En_Batch(testData)
For i = 0 To UBound(returnData)
Debug.Print returnData(i)
Next
End Sub
Public Function FY(ByVal 语句 As String, Optional 源语言 As String = "zh", Optional 目标语言 As String = "en") As String
Dim par As String
Dim data() As String
par = generateReqStr(语句, LCase(源语言), LCase(目标语言))
data() = translateJson(getHttp(par))
FY = LCase(data(3))
End Function
