'=============================================================================
' 临时排查脚本：精准定位 OLE DB 多步操作错误 (-2147217887)
'=============================================================================
Sub DebugOleDbError()
    Dim ws As Worksheet
    Dim r As Long, testRow As Long
    Dim conn As Object, rs As Object
    Dim dbPath As String, connStr As String, strSQL As String
    Dim pcNo As String, seqNo As String
    Dim fName As String
    Dim valToVerify As Variant

    dbPath = "\\192.168.110.114\生产进度表\2026年数据\执行卡下发记录.accdb"
    connStr = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & dbPath & ";Uid=Admin;Pwd=;"

    Set ws = ThisWorkbook.Worksheets("货期检查")

    ' 找到第一条填写了【修正交货日期】的数据进行测试
    For r = 4 To ws.Cells(ws.Rows.count, 1).End(xlUp).Row
        If Trim(CStr(ws.Cells(r, 10).Value)) <> "" Then
            testRow = r
            Exit For
        End If
    Next r

    If testRow = 0 Then
        MsgBox "没有找到填写了【修正交货日期】的数据，无法测试！", vbExclamation
        Exit Sub
    End If

    Set conn = CreateObject("ADODB.Connection")
    conn.Open connStr

    pcNo = Replace(Trim(CStr(ws.Cells(testRow, 1).Value)), "'", "''")
    seqNo = Trim(CStr(ws.Cells(testRow, 2).Value))

    strSQL = "SELECT * FROM 货期修改记录 WHERE [排产号]='" & pcNo & "' AND [序号]=" & seqNo
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open strSQL, conn, 1, 3

    If rs.EOF Then rs.AddNew

    ' ==========================================
    ' 开始逐个字段缓慢写入，开启错误捕捉
    ' ==========================================
    On Error GoTo CatchErr

    If rs.EOF Then
        fName = "排产号": valToVerify = ws.Cells(testRow, 1).Value: rs.Fields(fName).Value = valToVerify
        fName = "序号": valToVerify = ws.Cells(testRow, 2).Value: rs.Fields(fName).Value = valToVerify
    End If

    fName = "产品名称": valToVerify = ws.Cells(testRow, 3).Value: rs.Fields(fName).Value = valToVerify
    fName = "规格": valToVerify = ws.Cells(testRow, 4).Value: rs.Fields(fName).Value = valToVerify
    fName = "型号": valToVerify = ws.Cells(testRow, 5).Value: rs.Fields(fName).Value = valToVerify
    fName = "业务员": valToVerify = ws.Cells(testRow, 6).Value: rs.Fields(fName).Value = valToVerify

    fName = "数量"
    If IsNumeric(ws.Cells(testRow, 7).Value) And Not IsEmpty(ws.Cells(testRow, 7).Value) Then
        valToVerify = ws.Cells(testRow, 7).Value
    Else
        valToVerify = 0
    End If
    rs.Fields(fName).Value = valToVerify

    fName = "签订日期": If IsDate(ws.Cells(testRow, 8).Value) Then valToVerify = CDate(ws.Cells(testRow, 8).Value): rs.Fields(fName).Value = valToVerify
    fName = "交货日期": If IsDate(ws.Cells(testRow, 9).Value) Then valToVerify = CDate(ws.Cells(testRow, 9).Value): rs.Fields(fName).Value = valToVerify
    fName = "修正交货日期": If IsDate(ws.Cells(testRow, 10).Value) Then valToVerify = CDate(ws.Cells(testRow, 10).Value): rs.Fields(fName).Value = valToVerify

    fName = "产品分类": valToVerify = ws.Cells(testRow, 11).Value: rs.Fields(fName).Value = valToVerify
    fName = "BIP货期": If IsNumeric(ws.Cells(testRow, 12).Value) Then valToVerify = ws.Cells(testRow, 12).Value: rs.Fields(fName).Value = valToVerify
    fName = "BIP货期_工作日": If IsNumeric(ws.Cells(testRow, 13).Value) Then valToVerify = ws.Cells(testRow, 13).Value: rs.Fields(fName).Value = valToVerify
    fName = "工厂货期_工作日": If IsNumeric(ws.Cells(testRow, 14).Value) Then valToVerify = ws.Cells(testRow, 14).Value: rs.Fields(fName).Value = valToVerify

    fName = "添加记录的时间"
    valToVerify = Now: rs.Fields(fName).Value = valToVerify

    ' 最后一步提交
    fName = "提交更新 (rs.Update)"
    valToVerify = "无(最后提交环节)"
    rs.Update

    MsgBox "测试通过！说明第一条数据没问题。可能是后面的某一行数据触发了报错，我们可以进一步排查。"
    rs.Close
    conn.Close
    Exit Sub

CatchErr:
    Dim errMsg As String
    errMsg = Err.Description

    ' 安全清理
    On Error Resume Next
    rs.CancelUpdate
    rs.Close
    conn.Close

    MsgBox "?? 抓到导致 OLE DB 错误的内鬼了！" & vbCrLf & vbCrLf & _
           "错误发生在处理字段：【" & fName & "】" & vbCrLf & _
           "试图写入的值为：[" & CStr(valToVerify) & "]" & vbCrLf & vbCrLf & _
           "?? 常见原因分析：" & vbCrLf & _
           "1. 超长：这串内容是不是太长了？(超过了Access中该字段的长度限制)" & vbCrLf & _
           "2. 空值拒绝：如果写入的值是空[]，检查Access中该字段是否设置了【必填=是】或【允许空字符串=否】。" & vbCrLf & _
           "3. 如果错误发生在【提交更新】阶段，说明有必填字段被漏掉了！" & vbCrLf & vbCrLf & _
           "系统报错: " & errMsg, vbCritical
End Sub