c0f8d8163d
- Fix test result indicators encoding (use ?? instead of Unicode symbols) - Add missing newlines at end of files - Add new VBA module files for main functionality Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
106 lines
4.9 KiB
QBasic
106 lines
4.9 KiB
QBasic
'=============================================================================
|
||
' 临时排查脚本：精准定位 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 |