MS Access ODBC批量插入报运行时错误3035（系统资源超出）

问题背景 #

我在MS Access开发过程中需要实现本地数据批量写入SQL Server链接表的功能：待插入数据来自基于本地表构建的bulk_insert查询，共102列纯数据，无计算字段、无函数调用，测试数据量在6000~10000条区间，目标表为SQL Server链接表dbo_tblCVR_Matching_tmp。
最初参考公开的ODBC链接表批量插入方案编写代码后，程序仅能成功写入部分记录，运行一段时间就会触发**ODBC - 系统资源不足（运行时错误3035）**报错，报错位置固定为SQL执行语句行。查阅大量资料后未找到直接适配该场景的方案，经过多轮调试最终形成可稳定运行的实现，整理如下供同类场景参考。

初始存在问题的实现代码 #

最初版本按固定1000行拆分批次，未做特殊字符处理、未控制单条SQL长度，代码如下：

' 批量插入主过程（初始问题版本）
Sub bulk_insert()
    Dim cdb As DAO.Database
    Dim rst As DAO.Recordset
    Dim t0 As Single
    Dim i As Long
    Dim c As Long
    Dim valueList As String
    Dim separator As String
    Dim separator2 As String

    t0 = Timer
    Set cdb = CurrentDb
    Set rst = cdb.OpenRecordset("SELECT * FROM bulk_insert", dbOpenSnapshot)
    i = 0
    valueList = ""
    separator = ""

    Do Until rst.EOF
        i = i + 1
        valueList = valueList & separator & "("
        separator2 = ""
        For c = 0 To rst.Fields.Count - 1
            valueList = valueList & separator2 & "'" & rst.Fields(c) & "'"
            If c = 0 Then
                separator2 = ","
            End If
        Next c
        valueList = valueList & ")"
        
        If i = 1 Then
            separator = ","
        End If
        If i = 1000 Then
            SendInsert valueList
            i = 0
            valueList = ""
            separator = ""
        End If
        rst.MoveNext
    Loop

    If i > 0 Then
        SendInsert valueList
    End If
    rst.Close
    Set rst = Nothing
    Set cdb = Nothing
    Debug.Print "Elapsed time " & Format(Timer - t0, "0.0") & " seconds."
End Sub

' 插入执行子过程（初始问题版本）
Sub SendInsert(valueList As String)
    Dim cdb As DAO.Database
    Dim qdf As DAO.QueryDef

    Set cdb = CurrentDb
    Set qdf = cdb.CreateQueryDef("")

    qdf.Connect = cdb.TableDefs("dbo_tblCVR_Matching_tmp").Connect
    qdf.ReturnsRecords = False
    qdf.SQL = "INSERT INTO dbo.tblCVR_Matching_tmp (" & _
    "Associate_Id , Recd_Date, Price_Sheet_Eff_Date, VenAlpha, Mfg_Name, Mfg_Model_Num, Fei_Alt1_Code, Mfg_Product_Num, Base_Model_Num, Product_Description," & _
    "Qty_Base_UOM , Price_Invoice_UOM, Mfr_Pub_Sugg_List_Price, Mfr_Net_Price, IMAP_Pricing, Min_Order_Qty, UPC_GTIN, Each_Weight, Each_Length, Each_Width," & _
    "Each_Height, Inner_Pack_GTIN_Num, Inner_Pack_Qty, Inner_Pack_Weight, Inner_Pack_Length, Inner_Pack_Width, Inner_Pack_Height, Case_GTIN_Num, Case_Qty," & _
    "Case_Weight, Case_Length, Case_Width, Case_Height, Pallet_GTIN_Num, Pallet_Qty, Pallet_Weight, Pallet_Length, Pallet_Width, Pallet_Height, Pub_Price_Sheet_Eff_Date," & _
    "Price_Sheet_Name_Num, Obsolete_YN, Obsolete_Date, Obsolete_Stock_Avail_YN, Direct_Replacement, Substitution, Shelf_Life_YN, Shelf_Life_Time, Shelf_Life_UOM," & _
    "Serial_Num_Req_YN, LeadLaw_Compliant_YN, LeadLaw_3rd_Party_Cert_YN, LeadLaw_NonPotable_YN, Compliant_Prod_Sub, Compliant_Prod_Plan_Ship_Date, Green, GPF, GPM," & _
    "GPC, Freight_Class, Gasket_Material, Battery_YN, Battery_Type, Battery_Count, MSDS_YN, MSDS_Weblink, Hazmat_YN, UN_NA_Num, Proper_Shipping_Name," & _
    "Hazard_Class_Num, Packing_Group, Chemical_Name, ORMD_YN, NFPA_Storage_Class, Kit_YN, Load_Factor, Product_Returnable_YN, Product_Discount_Category," & _
    "UNSPSC_Code, Country_Origin, Region_Restrict_YN, Region_Restrict_Regulations, Region_Restrict_States, Prop65_Eligibile_YN, Prop65_Chemical_Birth_Defect," & _
    "Prop65_Chemical_Cancer, Prop65_Chemical_Reproductive, Prop65_Warning, CEC_Applicable_YN, CEC_Listed_YN, CEC_Model_Num, CEC_InProcess_YN, CEC_Compliant_Sub," & _
    "CEC_Compliant_Sub_Cross_YN, Product_Family_Name, Finish, Kitchen_Bathroom, Avail_Order_Date, FEI_Exclusive_YN, MISC1, MISC2, MISC3" & _
        ") Values " & valueList

    ' 报错固定触发在以下行
    qdf.Execute dbFailOnError
    Set qdf = Nothing
    Set cdb = Nothing
End Sub

核心优化点 #

调试过程中得到Albert Kallal的指导，最终落地的优化点如下：

• 前置数据去重：插入前先创建追加查询，将待写入记录导入带主键的本地临时表，从源头剔除重复数据，避免插入时主键冲突中断流程
• 复用直通查询对象：提前创建名为p的直通查询（Pass-Through Query），所有批次插入都复用该对象执行，避免反复创建临时QueryDef带来的额外资源开销
• 新增SQL转义逻辑：编写自定义转义函数，统一处理单引号转义、NULL值/空值的SQL语法适配，避免特殊字符导致的语法错误
• 动态生成插入字段：通过DLookup自动识别当前批次数据中全空的列，自动跳过这些字段减少SQL语句总长度，提升单批次可承载的行数
• 按SQL长度拆分批次：放弃固定1000行的拆分逻辑，设置单条SQL语句总长度阈值为48000字符，累计长度达到阈值就提交当前批次，避免单条SQL过长超出ODBC驱动的资源限制
• 批次间释放资源：每提交完一个批次后调用DoEvents释放系统占用的资源，避免资源累积占用触发阈值

稳定可用的最终代码 #

主插入过程 #

说明：代码中bi为预处理完成的待插入数据查询，需提前创建好名为p的直通查询并配置好SQL Server连接信息

' 感谢Albert Kallal提供的思路支持
Sub bulk_insert()
    Dim rstLocal  As DAO.Recordset
    Set rstLocal = CurrentDb.OpenRecordset("bi") ' bi为预处理完成的待插入数据查询

    Dim sBASE      As String      ' INSERT语句基础前缀
    Dim sValues    As String      ' 逐行拼接的VALUES子句

    Dim t As Single
    t = Timer

    Dim i          As Long
    Dim j          As Long
    Dim c As Long
    Dim ChunkSize  As Long    ' 单条SQL语句的最大字符长度阈值
    Dim separator2 As String
    Dim potentialHeader As String
    Dim test
    Dim filledArray() As Long

    ChunkSize = 48000        ' 经测试48000字符阈值在102列场景下稳定运行

    ' 动态生成INSERT前缀，自动跳过全空列
    With rstLocal
        If Not rstLocal.EOF Then
            sBASE = "INSERT INTO dbo.tblCVR_Matching_tmp ("
            ReDim filledArray(0 To .Fields.Count - 1)
            separator2 = ""
            For c = 0 To .Fields.Count - 1
                potentialHeader = .Fields(c).Name
                ' 检查当前列是否存在非空值
                test = DLookup(potentialHeader, "bi", potentialHeader & " is not null")
                If test <> "" Then
                    filledArray(c) = 1
                    sBASE = sBASE & separator2 & potentialHeader
                    separator2 = ","
                Else
                    filledArray(c) = 0
                End If
            Next c
            sBASE = sBASE & ") VALUES "
        End If
    End With

    Dim RowsInChunk  As Long  ' 记录当前批次包含的行数
    Dim RowCountOut  As Long
    sValues = ""
    Do While rstLocal.EOF = False
        RowCountOut = RowCountOut + 1

        If sValues <> "" Then sValues = sValues & ","

        RowsInChunk = RowsInChunk + 1
        sValues = sValues & "("
        separator2 = ""

        With rstLocal
            For c = 0 To .Fields.Count - 1
                If filledArray(c) = 1 Then
                    ' 调用转义函数处理字段值
                    sValues = sValues & separator2 & sql_escape(.Fields(c))
                    separator2 = ","
                End If
            Next c
        End With

        sValues = sValues & ")"

        ' 达到长度阈值时提交当前批次
        If (Len(sBASE) + Len(sValues)) >= ChunkSize Then
            With CurrentDb.QueryDefs("p")
                .SQL = sBASE & sValues
                .Execute
            End With

            Debug.Print "当前批次插入行数 = " & RowsInChunk
            RowsInChunk = 0
            sValues = ""
            DoEvents ' 释放系统资源
        End If

        rstLocal.MoveNext
    Loop

    ' 提交最后一个不足阈值的剩余批次
    If sValues <> "" Then
        With CurrentDb.QueryDefs("p")
            .SQL = sBASE & sValues
            .Execute
        End With
        sValues = ""
    End If

    rstLocal.Close
    t = Timer - t
    Debug.Print "插入完成，总耗时 = " & t & "秒"
End Sub

SQL转义自定义函数 #

' 处理字段值转义、空值适配
Public Function sql_escape(val As Variant)
    If LCase(val) = "null" Or val = "" Or IsNull(val) Then
        sql_escape = "NULL"
    Else
        ' 转义单引号避免SQL语法错误
        val = Replace(val, "'", "''")
        sql_escape = "'" & val & "'"
    End If
End Function

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