使用VBA JSON Parser导入Access表时出现数据类型不匹配错误

问题场景 #

使用VBA JSON库解析JSON文件导入MS Access测试表，运行代码时在qdef!FirstName = element("firstName")处触发数据类型不匹配错误，查询"AddEmp"的插入源为空，但通过MsgBox验证读取到的jsonStr内容正常。仅选择JSON中4个字段测试，源JSON为单层结构（数据嵌套在data数组中）。

原代码 #

Private Function JSONImport()

    Dim db As database, qdef As QueryDef
    Dim FileNum As Integer
    Dim DataLine As String, jsonStr As String, strSQL As String
    Dim p As Object, element As Variant

Set db = CurrentDb

    ' READ FROM EXTERNAL FILE
FileNum = FreeFile()
    Open "M:\ImportBamboo\Emp.json" For Input As #FileNum

    ' PARSE FILE STRING
    jsonStr = ""
    While Not EOF(FileNum)
        Line Input #FileNum, DataLine

        jsonStr = jsonStr & DataLine & vbNewLine
    Wend
    Close #FileNum
    Set p = ParseJson(jsonStr)
    'MsgBox jsonStr
    
    ' ITERATE THROUGH DATA ROWS, APPENDING TO TABLE
    For Each element In p
        strSQL = "PARAMETERS [firstName] Text(255), [lastName] Text(255), " _
                          & "[SSN] Text(255), [maritalStatus] Text(255); " _
                  & "INSERT INTO BambooEmpTest (FirstName, LastName, SSN, MaritalStatus) " _
                          & "VALUES([firstName], [lastName], [SSN], [maritalStatus]);"

        Set qdef = db.CreateQueryDef("AddEmp", strSQL)

        qdef!FirstName = element("firstName")
        qdef!LastName = element("lastName")
        qdef!SSN = element("ssn")
        qdef!MaritalStatus = element("maritalStatus")

        qdef.Execute
    Next element

    Set element = Nothing
    Set p = Nothing
End Function

源JSON结构示例 #

{
  "data": [
    {
      "firstName": "Fred",
      "lastName": "Smith",
      "dateOfBirth": "1980-02-04",
      "ssn": "666-66-6666",
      "maritalStatus": "Married",
      "addressLineOne": "666 Delancey Street",
      "addressLineTwo": "Apt 666",
      "city": "San Francisco",
      "state": "CA",
      "zipcode": "94107",
      "workPhone": "415-555-6666",
      "mobilePhone": "415-555-6666",
      "homePhone": null,
      "email": "test@test.com",
      "homeEmail": "test@gmail.com",
      "hireDate": "2024-09-16",
      "compensationPayType": "Salary",
      "compensationPayRate": "1 USD",
      "compensationPaidPer": "Year",
      "jobInformationDivision": "10",
      "compensationPaySchedule": "Salaried Employees",
      "employmentStatusEffectiveDate": "2024-09-16",
      "employmentStatus": "Full-Time, Salaried, Exempt",
      "employmentStatusTerminationType": null,
      "supervisorEid": "188",
      "supervisorName": "Smith, Joe",
      "terminationDate": null,
      "preferredName": "Freddie",
      "employeeNumber": "10-0091303",
      "status": "Active",
      "compensationEffectiveDate": "2024-09-16",
      "jobInformationDepartment": "Operations",
      "compensationOvertimeStatus": "Exempt"
    }
    // 更多记录...
  ]
}

测试表结构 #

错误原因分析 #

1. JSON层级定位错误：原代码直接遍历p（整个JSON根对象），但实际员工数据嵌套在根对象的data数组中，element此时指向的是根对象而非单个员工对象，导致访问element("firstName")时出现类型不匹配。
2. QueryDef重复创建冲突：循环内重复创建同名QueryDefAddEmp，会导致对象引用异常。
3. 空值未处理：JSON中的null值直接赋值会引发Access数据类型错误。

修正后的代码 #

Private Function JSONImport()
    Dim db As Database, qdef As QueryDef
    Dim FileNum As Integer
    Dim DataLine As String, jsonStr As String, strSQL As String
    Dim p As Object, dataArray As Object, element As Variant

    Set db = CurrentDb

    ' 读取JSON文件
    FileNum = FreeFile()
    Open "M:\ImportBamboo\Emp.json" For Input As #FileNum
    jsonStr = ""
    While Not EOF(FileNum)
        Line Input #FileNum, DataLine
        jsonStr = jsonStr & DataLine & vbNewLine
    Wend
    Close #FileNum

    ' 解析JSON并定位到data数组
    Set p = ParseJson(jsonStr)
    Set dataArray = p("data") ' 关键：获取实际数据所在的数组

    ' 预定义插入SQL（循环外创建一次即可）
    strSQL = "PARAMETERS [firstName] Text(255), [lastName] Text(255), " _
              & "[SSN] Text(255), [maritalStatus] Text(255); " _
              & "INSERT INTO BambooEmpTest (FirstName, LastName, SSN, MaritalStatus) " _
              & "VALUES([firstName], [lastName], [SSN], [maritalStatus]);"

    ' 遍历data数组中的每个员工对象
    For Each element In dataArray
        ' 创建临时QueryDef（不指定名称，避免重复）
        Set qdef = db.CreateQueryDef("", strSQL)

        ' 处理空值：JSON的Null转Access的Null
        qdef!FirstName = IIf(IsNull(element("firstName")), Null, element("firstName"))
        qdef!LastName = IIf(IsNull(element("lastName")), Null, element("lastName"))
        qdef!SSN = IIf(IsNull(element("ssn")), Null, element("ssn"))
        qdef!MaritalStatus = IIf(IsNull(element("maritalStatus")), Null, element("maritalStatus"))

        qdef.Execute dbFailOnError ' 启用错误捕获，便于排查问题
        qdef.Close ' 关闭QueryDef
        Set qdef = Nothing ' 释放资源
    Next element

    ' 释放所有对象
    Set element = Nothing
    Set dataArray = Nothing
    Set p = Nothing
    Set db = Nothing
End Function

关键修正点 #

• 新增dataArray = p("data")，定位到实际存储员工数据的数组
• 将QueryDef创建逻辑移到循环外，循环内使用临时无名称QueryDef，避免重复命名冲突
• 添加IIf(IsNull(...), Null, ...)处理JSON中的null值，匹配Access字段的空值规则
• 启用dbFailOnError参数，执行时若出错会抛出详细错误信息，便于排查

内容的提问来源于stack exchange，提问作者5uperBonbon