EXCEL VBA调用百度api识别身份证

码猩

于 2024-02-01 21:55:03 发布

阅读量803

点赞数 6

分类专栏： excelVBA专栏文章标签： excel

本文链接：https://blog.csdn.net/weixin_43050480/article/details/135982812

版权

excelVBA专栏专栏收录该内容

39 篇文章 4 订阅

订阅专栏

EXCEL VBA调用百度api识别身份证

Sub BC_识别身份证()
    Dim SHD, SHX As Worksheet
    Dim AppKey, SecretKey, Token, PathY As String
    Dim jSon, JSonA, WithHttp As Object
    Dim Pic, oDom, oW, jsCode, params
    Dim ARX, BRX, DRX, ERX, ZAD
    Dim StrText, StrUrl As String
    Dim StrA, StrB, StrC  As String
    Dim I, X, K As Long
    
    
    Rem 禁止系统刷屏?触发其他事件等
    'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    
    
    Rem  获取百度Token
    Set SHX = Worksheets("参数")
    AppKey = SHX.Range("B1").Value
    SecretKey = SHX.Range("B2").Value
    Token = GetTokenBaiDu(AppKey:=AppKey, SecretKey:=SecretKey)
    
    Rem 指定发票文件, 可以是PDF,或JPG,PNG文件, 暂不支持: 一张放票内多条明细, 一个文件内多张发票
    PathY = GetFileName(KZM:="图片文件,*.png;*.bmp;*.jpeg;*.jpg", Title:="请选择图片文件", FileName:="", StrSplitor:="\")
    Open PathY For Binary As #1
    Dim chs() As Byte
    For I = 0 To LOF(1) - 1 '循环至文件末端
        ReDim Preserve chs(0 To K) As Byte '将文件内容存入字节数组
        Get #1, , chs(K) '获取文本内容
        K = K + 1
    Next I
    Close #1
    
    Pic = Byte2Base64(chs)
    Set oDom = CreateObject("htmlfile")
    Set oW = oDom.parentWindow
    jsCode = "encodeURIComponent('" & Pic & "');"
    Pic = oW.eval(jsCode)
    Rem Pic = WorksheetFunction.EncodeURL(Pic)
    params = "id_card_side=" + "front" + "&image=" & Pic
    '    params = "image=" & Pic
    StrUrl = "https://aip.baidubce.com/rest/2.0/ocr/v1/idcard?access_token=" & Token
    Set WithHttp = CreateObject("winhttp.winhttprequest.5.1")
    With WithHttp
        .Open "post", StrUrl, False
        .setRequestHeader "content-type", "application/x-www-form-urlencoded"
        .send (params)
        StrText = BytesToBstr(.Responsebody, "utf-8")
    End With
    Set oDom = Nothing
    Set oW = Nothing
    
    Rem SHX.Range("G4").Value = StrText '// StrText = SHX.Range("G4").Value
    
    Rem 创建JSON对象并将其赋值为要解析的JSON字符串
    Set jSon = JsonConverter.ParseJson(StrText)
    Rem  jSon.Count & vbCrLf & jSon.Items()(0) & vbCrLf & jSon.keys()(0)
    Rem JSON("forecast")("forecastday")("hour")(i)("time_epoch")
    Rem  IntX = jSon("words_result")("CommodityName").Count
    
    Rem 写到字典中
    Set ZAD = CreateObject("Scripting.Dictionary")
    If InStr(StrText, "姓名") = 0 Then
        If InStr(StrText, "签发日期") > 0 Then
            ZAD("签发日期") = jSon("words_result")("签发日期")("words")
            ZAD("失效日期") = jSon("words_result")("失效日期")("words")
            ZAD("签发机关") = jSon("words_result")("签发机关")("words")
        Else
            ZAD("错误") = "识别失败,返回结果错误"
        End If
    Else
        ZAD("姓名") = jSon("words_result")("姓名")("words")
        ZAD("性别") = jSon("words_result")("性别")("words")
        ZAD("出生日期") = jSon("words_result")("出生")("words")
        ZAD("身份号码") = jSon("words_result")("公民身份号码")("words")
        ZAD("民族") = jSon("words_result")("民族")("words")
        ZAD("住址") = jSon("words_result")("住址")("words")
    End If
    
    Rem 写入数组并输出
    ERX = ZAD.keys
    ReDim DRX(0 To UBound(ERX), 0 To 1)
    For X = 0 To UBound(ERX)
        DRX(X, 0) = ERX(X)
        DRX(X, 1) = ZAD(ERX(X))
    Next
    
    Set SHD = Worksheets("test")
    SHD.Range("A:B").ClearContents
    SHD.Range("A1").Resize(UBound(DRX, 1) + 1, UBound(DRX, 2) + 1) = DRX
    
    MsgBox UBound(DRX, 1), vbInformation, "识别成功"
End Sub