EXCEL VBA调用百度API翻译

EXCEL VBA调用百度API翻译

python 复制代码
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
相关推荐
Goona_2 小时前
拒绝SQL恐惧:用Python+pyqt打造任意Excel数据库查询系统
数据库·python·sql·excel·pyqt
忘忧记2 小时前
excel删除重复项场景
excel
UrbanJazzerati4 小时前
Excel 神器 COUNTIFS 函数详解:多条件计数实战
excel
百度SEO专员1 天前
2025最新蜘蛛池在百度SEO中的应用
dubbo
想学习java初学者1 天前
SpringBoot整合Fastexcel/EasyExcel导出Excel导出单个图片
excel
LAM LAB1 天前
【WPS】office邮件合并,怎么将数据源excel中的下一条拼接在文档中的下一个位置
excel·wps
SEO-狼术1 天前
Document Solutions for Excel, .NET
excel
程序员的世界你不懂2 天前
Jmeter常见问题分析(1)乱码问题
jmeter·dubbo
Access开发易登软件2 天前
Access开发一键删除Excel指定工作表
服务器·前端·后端·excel·vba·access·access开发
Saggitarxm2 天前
Golang实现 - 实现只有表头的 Excel 模板,并在指定列添加了下拉框功能。生成的 Excel 文件在打开时,指定列的单元格会显示下拉选项
excel·下拉框选项序列·生成excel模板·下拉框选项