EXCEL VBA调用百度API翻译

Public Function translateZh_En(ByVal str As String) As String'调用百度翻译API，将指定内容由中文翻译为英文Dim par As StringDim data() As Stringpar = 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 FunctionPublic Function translateZh_En_Batch(ByRef arr() As String) As String()'调用百度翻译API，将指定内容由中文翻译为英文Dim par As StringDim data() As StringDim returnData() As StringDim resp As Stringpar = generateReqStrBatch(arr, "zh", "en")resp = getHttp(par)  '调用API,获取API 返回data() = translateJsonBatch(resp) '调用JSON转换函数，解析API返回的结果ReDim returnData(UBound(data) - 4) As StringFor i = 0 To UBound(data) - 4returnData(i) = UCase(Split(data(i), "|", -1, vbTextCompare)(1))NexttranslateZh_En_Batch = returnData() '获取API返回的翻译结果End FunctionPublic Function translateEn_Zh(ByVal str As String) As String'调用百度翻译API，将指定内容由英文翻译为中文Dim par As StringDim data() As Stringpar = generateReqStr(str, "en", "zh")data() = translateJson(getHttp(par)) '调用API,获取API 返回, '调用JSON转换函数，解析API返回的结果translateEn_Zh = data(3)End FunctionPublic Function translateEn_Zh_Batch(ByRef arr() As String) As String()'调用百度翻译API，将指定内容由英文翻译为中文Dim par As StringDim data() As StringDim returnData() As StringDim resp As Stringpar = generateReqStrBatch(arr, "en", "zh")resp = getHttp(par)  '调用API,获取API 返回data() = translateJsonBatch(resp) '调用JSON转换函数，解析API返回的结果ReDim returnData(UBound(data) - 4) As StringFor i = 0 To UBound(data) - 4returnData(i) = Split(data(i), "|", -1, vbTextCompare)(1)NexttranslateZh_En_Batch = returnData() '获取API返回的翻译结果End FunctionPublic 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，不允许POSTgetHttp = HttpReq.responsetextEnd FunctionPublic 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，不允许POSTgetHttp = HttpReq.responsetextEnd FunctionPublic Function generateReqStr(q As String, from_Str As String, to_Str As String) As String
'生成Request 字符串Dim appid As StringDim key As StringDim salt As IntegerDim sign As StringDim par As StringMath.Randomize (Timer)salt = (Rnd * 1000000) Mod 20000key = "修改为你自己申请的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 = parEnd FunctionPublic Function generateReqStrBatch(q() As String, from_Str As String, to_Str As String) As String
'生成Request 字符串Dim appid As StringDim key As StringDim salt As IntegerDim sign As StringDim par As StringDim str1 As String'Dim ln As String'ln = ChrB(10) & ChrB(0)Math.Randomize (Timer)salt = (Rnd * 1000000) Mod 20000key = "修改为你自己申请的API的Key"appid = "修改为你自己申请的API的appid"For i = LBound(q) To UBound(q)str1 = str1 & q(i) & vbLfNext'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 = parEnd FunctionPublic 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_resultreturnData(0) = objJSON.from
'returnData(1) = objJSON.To'获取第二层的结果
'Debug.Print CallByName(objJSON2, "src", VbGet)  '这是另一种获取属性的方法
'Debug.Print objJSON2.dstreturnData(2) = objJSON2.src
returnData(3) = objJSON2.dst'如果API执行结果不正确，获取API的不正确的返回信息。
On Error GoTo ErrorHandler
returnData(4) = objJSON.error_code
returnData(5) = objJSON.error_msgtranslateJson = returnData
Exit FunctionErrorHandler:
returnData(4) = ""
returnData(5) = ""
translateJson = returnData
Exit FunctionErrorHandler1:
returnData(0) = ""
returnData(1) = ""
returnData(2) = ""
returnData(3) = ""
returnData(4) = objJSON.error_code
returnData(5) = objJSON.error_msg
translateJson = returnData
Exit FunctionEnd FunctionPublic 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) ThenReDim 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.srcreturnData(3) = objJSON2.dstreturnData2(i) = returnData(2) & "|" & returnData(3)NextElseReDim 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 = returnData2Exit FunctionErrorHandler:
'获取错误信息失败，则设置错误信息为空
returnData(4) = ""
returnData(5) = ""
returnData2(UBound(returnData2) - 1) = returnData(4)
returnData2(UBound(returnData2)) = returnData(5)
translateJsonBatch = returnData2
Exit FunctionErrorHandler1: '获取第一层数据失败，则返回错误信息
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 FunctionErrorHandler2: '获取第一层数据失败，则返回错误信息ReDim returnData2(4) As String  '无数据返回，则数据区域返回空returnData2(0) = " | "translateJsonBatch = returnData2
Exit FunctionEnd FunctionPublic Function encode(ByVal str As String) As String
'调用JavaScript的encodeURIComponent方法进行urlencode 编码Dim js As ObjectDim strFun As StringDim data As StringSet 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 strFuncstr = Replace(str, vbCrLf, "\r\n")  '转换回车换行符为URL回车换行符str = Replace(str, vbLf, "\n")   '转换换行符为URL换行符data = js.CodeObject.getjson(str)'Debug.Print dataencode = data
End FunctionSub testTranslate()Debug.Print translateZh_En("感觉身体被掏空")Dim testData() As StringReDim testData(5)testData(0) = "苹果"testData(1) = "香蕉"testData(2) = "不作就不会死"testData(3) = "红色"testData(4) = "绿色"testData(5) = "黄色"Dim returnData() As StringreturnData = 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 StringDim par As StringDim data() As Stringpar = generateReqStr(语句, LCase(源语言), LCase(目标语言))data() = translateJson(getHttp(par))FY = LCase(data(3))
End Function