Function BaiDuOCR(APIKey, SecretKey, ImgPath, OcrType)
Dim http, ReJson, url, formStr, token, PhotoBS, httpBody
Dim xml_dom, Node, FileByteArrs, Stream, ReExpObj, Matches
Dim adTypeBinary, adModeReadWrite, adTypeText
adTypeBinary = 1
adModeReadWrite = 3
adTypeText = 2
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
Set sStream = CreateObject("ADODB.Stream")
url = "https://aip.baidubce.com/oauth/2.0/token?"
formStr = "grant_type=client_credentials&" & _
"client_id=" & APIKey & "&" & _
"client_secret=" & SecretKey & "&"
With http
.Open "POST", url
.SetRequestHeader "Conent-Length", Len(formStr)
.Send formStr
End With
ReJson = http.ResponseText
Set ReExpObj = CreateObject("VBScript.RegExp")
ReExpObj.[Global] = True
ReExpObj.Pattern = "access_token"":""(.+?)"""
If ReExpObj.Test(ReJson) Then
Set Matches = ReExpObj.Execute(ReJson)
token = Matches(0).SubMatches(0)
Else
MsgBox "获取Token失败!" & vbcrlf & ReJson
End If
With sStream
.Mode = adModeReadWrite
.Type = adTypeBinary
.Open
.LoadFromFile (ImgPath)
.Position = 0
FileByteArr = .Read
.Close
End With
Set xml_dom = CreateObject("Microsoft.XMLDOM")
With xml_dom
.loadXML ("")
Set Node = .createElement("HTML")
With Node
.dataType = "bin.base64"
.nodeTypedValue = FileByteArr
PhotoBS = .Text
End With
End With
PhotoBS = Replace(PhotoBS,"+","%2b")
PhotoBS = Replace(PhotoBS, "/", "%2f")
PhotoBS = Replace(PhotoBS,"=","%3d")
With http
If OcrType = "通用文字识别" Then
formStr = "image=" & PhotoBS & "&image_url="
.Open "POST", "https://aip.baidubce.com/rest/2.0/ocr/v1/general?access_token=" & CStr(token), False
ElseIf OcrType = "通用图像识别" Then
formStr = "image=" & PhotoBS
.Open "POST", "https://aip.baidubce.com/rest/2.0/image-classify/v2/advanced_general?access_token=" & CStr(token), False
End If
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.SetRequestHeader "Conent-Length", Len(formStr)
.Send formStr
httpBody = .ResponseBody
End With
With sStream
.Mode = adModeReadWrite
.Type = adTypeBinary
.Open
.Write httpBody
.Position = 0
.Type = adTypeText
.Charset = "utf-8"
BaiDuOCR = .ReadText
.Close
End With
Set Node = Nothing
Set xml_dom = Nothing
Set sStream = Nothing
End Function
Function BrowseForFile()
on Error Resume Next
Dim shell: Set shell = CreateObject("WScript.Shell")
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim tempFolder: Set tempFolder = fso.GetSpecialFolder(2)
Dim tempName: tempName = fso.GetTempName()
Dim tempFile: Set tempFile = tempFolder.CreateTextFile(tempName & ".hta")
tempFile.Write _
"<html>" & _
"<head>" & _
"<title>Browse</title>" & _
"</head>" & _
"<body>" & _
"<input type='file' id='f' />" & _
"<script type='text/javascript'>" & _
"var f = document.getElementById('f');" & _
"f.click();" & _
"var shell = new ActiveXObject('WScript.Shell');" & _
"shell.RegWrite('HKEY_CURRENT_USER\\Volatile Environment\\MsgResp', f.value);" & _
"window.close();" & _
"</script>" & _
"</body>" & _
"</html>"
tempFile.Close
shell.Run tempFolder & "\" & tempName & ".hta", 0, True
BrowseForFile = shell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
shell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
Call fso.getfile(tempFolder & "\" & tempName & ".hta").Delete
End Function
//调用例子:
//以下APIKey 和 SecretKey是申请创建应用的时候自动生成的, 使用时注意保密
//Access Token自获取之时起有效期一个月,目前每天获取次数限制500次,应珍惜使用.其它限制参考百度AI页面说明
//文字识别能识别图中的文字; 图像识别能识别主体图像的各种属性,使用时根据识别结果中各种属性权重来确定图片内容更加贴切的解释
//======================================
//为了帮助各位群友方便理解,本例子中的APIKey 和 SecretKey是作者私人申请的,
//由于存在使用次数限制以及关系到账号安全,各位实际使用时请不要使用本例中参数.
//======================================
文字识别APIKey = "ZrUHuuGlR5O3uxFC08E0EgHP"
文字识别SecretKey = "Ar91rbgUXabo88TGDZfhBcfbLxIV8p8y"
TracePrint BaiDuOCR(文字识别APIKey, 文字识别SecretKey, BrowseForFile,"通用文字识别")
图像识别APIKey = "hVgaFXm9tjDCGIhLSYZSiH7T"
图像识别SecretKey = "fPO16eNe24BoGr25qoqHG5oVABa94lFU"
TracePrint BaiDuOCR(图像识别APIKey, 图像识别SecretKey, BrowseForFile, "通用图像识别")