VB6代码无法实现ADODB记录集数据复制，求排查故障原因

运行环境 #

• 开发环境：纯VB6 SP3（专业版8169）
• 操作系统：Windows 8.1（版本6.3.9600）
• 硬件：东芝Satellite S75t-A、Intel Core i7-4700MQ

执行下方DBTrans子程序时弹出报错对话框，该代码旨在将源数据库的Passwords记录集数据复制到目标数据库同名记录集，但无法完成复制，求排查原因：

Public Sub DBTrans()
    Dim OldNum As Integer, NewNum As Integer
    Dim New_CDBS, New_WRS, Old_CDBS, Old_WRS
    Dim Resp, Rec As Integer
    Dim i As Integer
    Dim Txt0, Txt1, Txt2, Txt3, Txt5, Txt6
    
    
    ' Open the Database you are getting records 'FROM'
    Set Old_CDBS = OpenDatabase(SourceDB, True)
    Set Old_WRS = Old_CDBS.OpenRecordset("Passwords", dbOpenDynaset)
    
    ' Open the DataBase you are sending Records 'TO'
    Set New_CDBS = OpenDatabase(DestinationDB, True)
    Set New_WRS = CDBS.OpenRecordset("Passwords", dbOpenDynaset)
    
    On Error GoTo ErrRes
    
    Old_WRS.MoveFirst   ' Initialize Source Database
    Old_WRS.MoveLast
    Old_WRS.MoveFirst
    i = 1
    
    Do Until Old_WRS.EOF = True     'Cycle through all Records in the Source Database in this 'DO' Loop
        With New_WRS
         ' This was a test workaround effort
         '   Txt0 = Old_WRS.Fields(0)
         '   Txt1 = Old_WRS.Fields(1)
         '   Txt2 = Old_WRS.Fields(2)
         '   Txt3 = Old_WRS.Fields(3)
         '   Txt4 = Old_WRS.Fields(4)       ' OR Rec_Num OR i
         '   Txt5 = Old_WRS.Fields(5)
         '   Txt6 = Old_WRS.Fields(6)
        
            .AddNew     ' Add A new Record to the Destination Database
            .Fields(0).Value = Old_WRS.Fields(0)        '= Txt0   ' Location
            .Fields(1).Value = Old_WRS.Fields(1)        '= Txt1   ' Logon
            .Fields(2).Value = Old_WRS.Fields(2)        '= Txt2   ' Password
            .Fields(3).Value = Old_WRS.Fields(3)        '= Txt3   ' Notes - AllowZeroLength Field
            .Fields(5).Value = Old_WRS.Fields(5)        '= Txt5   ' Format(Txt5, "mm/dd/yyyy")
            .Fields(6).Value = Old_WRS.Fields(6)        '= Txt6   ' Name
            
            .Fields(4).Value = Old_WRS.Fields(4)        ' New_Index 'OR' Rec_Num
           
          '  i = i + 1      ' Next index OR Rec_Num
            .Update
            .MoveFirst
            .MoveLast
                        
        End With
        Old_WRS.MoveNext        ' Move to next Source Database Record
        
    Loop                    ' Start Next data Transaction.
    
    ' Old_WRS.RecordCount is complete
    ' now Verify transfer with simple RecordSet.Count comparison
    OldNum = Old_WRS.RecordCount
    NewNum = New_WRS.RecordCount
    Old_WRS.Close
    Old_CDBS.Close
    New_WRS.Close
    Old_CDBS.Close
    
    
    If NewNum = OldNum Then
        MsgBox ("Transfer complete: Old DB = " & OldNum & "Records" & vbCr & "New DB has " & NewNum & "Records."), vbOKOnly
    Else
        MsgBox ("Something went wrong: Old DB = " & OldNum & "Records" & vbCr & "New DB has " & NewNum & " Records."), vbOKOnly
    End If

ErrRes:

    MsgBox "The Following Error Occurred:" & vbCr & vbCr & Err.Description & vbCr & "Aborting Edit Operation", vbOKOnly, "Error Alert"
    Form1.Visible = True
    Form1.Enabled = True
    Unload Form4

End Sub

核心错误排查与修复方案 #

1. 致命对象引用错误 #

打开目标记录集时，代码误写为Set New_WRS = CDBS.OpenRecordset(...)，但实际定义的目标数据库对象是New_CDBS，这会直接触发“变量未定义”错误，需修改为：

Set New_WRS = New_CDBS.OpenRecordset("Passwords", dbOpenDynaset)

2. 错误处理位置错误 #

原代码将On Error GoTo ErrRes放在数据库打开操作之后，导致打开数据库时的错误无法被捕获，需将错误处理语句移到子程序开头。

3. 冗余操作导致效率与异常问题 #

每次添加记录后执行.MoveFirst和.MoveLast完全无必要，会大幅降低迁移效率，且可能引发记录集状态异常，直接删除这两行代码。

4. 重复关闭数据库对象 #

代码末尾重复执行Old_CDBS.Close，第二次关闭时对象已释放，会触发错误，需改为关闭目标数据库对象：

New_CDBS.Close

5. 未显式声明变量类型 #

New_CDBS、New_WRS等变量未声明具体类型（应为Database和Recordset），VB6默认视为Variant类型，易引发类型不兼容问题，建议添加Option Explicit并显式声明变量：

Option Explicit
Dim New_CDBS As Database, New_WRS As Recordset
Dim Old_CDBS As Database, Old_WRS As Recordset

6. 错误处理逻辑缺陷 #

原错误处理块未添加退出语句，会继续执行后续代码引发更多异常，需在正常流程末尾添加Exit Sub，并在错误处理块中确保所有数据库对象被正确关闭。

修复后的完整代码 #

Option Explicit

Public Sub DBTrans()
    Dim OldNum As Integer, NewNum As Integer
    Dim New_CDBS As Database, New_WRS As Recordset
    Dim Old_CDBS As Database, Old_WRS As Recordset
    
    On Error GoTo ErrRes
    
    ' 打开源数据库
    Set Old_CDBS = OpenDatabase(SourceDB, True)
    Set Old_WRS = Old_CDBS.OpenRecordset("Passwords", dbOpenDynaset)
    
    ' 打开目标数据库
    Set New_CDBS = OpenDatabase(DestinationDB, True)
    Set New_WRS = New_CDBS.OpenRecordset("Passwords", dbOpenDynaset)
    
    ' 定位到源记录集末尾以获取准确记录数
    Old_WRS.MoveLast
    Old_WRS.MoveFirst
    
    ' 循环复制记录
    Do Until Old_WRS.EOF
        With New_WRS
            .AddNew
            .Fields(0).Value = Old_WRS.Fields(0)  ' Location
            .Fields(1).Value = Old_WRS.Fields(1)  ' Logon
            .Fields(2).Value = Old_WRS.Fields(2)  ' Password
            .Fields(3).Value = Old_WRS.Fields(3)  ' Notes
            .Fields(4).Value = Old_WRS.Fields(4)  ' New_Index
            .Fields(5).Value = Old_WRS.Fields(5)  ' 日期字段
            .Fields(6).Value = Old_WRS.Fields(6)  ' Name
            .Update
        End With
        Old_WRS.MoveNext
    Loop
    
    ' 验证记录数
    OldNum = Old_WRS.RecordCount
    NewNum = New_WRS.RecordCount
    
    ' 关闭所有数据库对象
    Old_WRS.Close
    Old_CDBS.Close
    New_WRS.Close
    New_CDBS.Close
    
    ' 提示结果
    If NewNum = OldNum Then
        MsgBox "传输完成：原数据库 = " & OldNum & "条记录" & vbCr & "新数据库 = " & NewNum & "条记录。", vbOKOnly
    Else
        MsgBox "传输异常：原数据库 = " & OldNum & "条记录" & vbCr & "新数据库 = " & NewNum & "条记录。", vbOKOnly
    End If
    
    Exit Sub ' 正常退出，避免进入错误处理

ErrRes:
    MsgBox "发生以下错误：" & vbCr & vbCr & Err.Description & vbCr & "终止操作", vbOKOnly, "错误提示"
    Form1.Visible = True
    Form1.Enabled = True
    Unload Form4
    
    ' 确保所有对象被关闭，避免内存泄漏
    If Not Old_WRS Is Nothing Then Old_WRS.Close
    If Not Old_CDBS Is Nothing Then Old_CDBS.Close
    If Not New_WRS Is Nothing Then New_WRS.Close
    If Not New_CDBS Is Nothing Then New_CDBS.Close
End Sub

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