Access三级嵌套窗体记录复制VBA运行错误3078修复求助

问题描述 #

• 需求：实现Access主窗体、二级子窗体、三级子窗体三层嵌套结构的关联记录一键复制
• 故障现象：主窗体、二级子窗体记录可正常复制，三级子窗体仅能复制第一条关联记录，同时触发运行时错误3078: The Microsoft Office Access database engine cannot find the input table or query. Make sure it exists and that its name is spelled correctly.

故障根因 #

1. 代码中声明了SQL字符串变量strSql但从未赋值，循环内直接执行该空SQL触发3078错误，直接中断三级记录的遍历循环，导致仅第一条三级记录被复制
2. 三级子窗体记录计数重复累加，复制数量统计结果不准确
3. 无异常兜底逻辑，代码运行出错时记录集不会自动关闭，易造成表锁残留

修复后完整代码 #

Private Sub cmdDuplicatePHIP_Click()
'功能：复制主窗体记录及关联的二级、三级子窗体记录
    Dim db As DAO.Database
    Dim rstT2 As DAO.Recordset  '二级表TRD_RDLog待复制记录集
    Dim rstT2A As DAO.Recordset '二级表TRD_RDLog新记录写入目标集
    Dim rstT3 As DAO.Recordset  '三级表TFP_PHIPDtl待复制记录集
    Dim rstT3A As DAO.Recordset '三级表TFP_PHIPDtl新记录写入目标集
    
    Dim lngT1PK As Long    '主表TRD_RDTrial当前记录主键
    Dim lngT2PK As Long    '二级表TRD_RDLog当前记录主键
    Dim lngT3PK As Long    '三级表TFP_PHIPDtl当前记录主键
    Dim lngT1NewFK As Long '主表新记录主键（作为二级表外键）
    Dim lngT2NewFK As Long '二级表新记录主键（作为三级表外键）
    Dim lngT3NewFK As Long '三级表新记录主键
    
    Dim strSql_S As String '二级表查询SQL
    Dim strSql_A As String '三级表查询SQL
    Dim msg As String      '结果提示文本
    
    '各表复制成功计数
    Dim intRC_CD As Integer '主表TRD_RDTrial
    Dim intRC_CS As Integer '二级表TRD_RDLog
    Dim intRC_CA As Integer '三级表TFP_PHIPDtl
    
    '先保存当前窗体未提交的编辑内容
    If Me.Dirty Then Me.Dirty = False
    
    On Error GoTo ErrorHandler
    Set db = CurrentDb

    '判断是否选中待复制记录
    If Me.NewRecord Then
        MsgBox "请先选中需要复制的记录。"
        GoTo Cleanup
    End If

    '===== 复制主表记录 =====
    lngT1PK = Me.TRPK
    With Me.RecordsetClone
        .AddNew
        !TrialDate = Me.TrialDate
        !TrialBy = Me.TrialBy
        !QC = Me.QC
        '其余主表字段按相同格式补充即可
        .Update
        intRC_CD = intRC_CD + 1
        '获取新生成的主表主键
        .Bookmark = .LastModified
        lngT1NewFK = !TRPK
    End With

    '===== 复制二级表关联记录 =====
    '打开二级表全量写入集
    strSql_S = " SELECT TDPK, TRPK, RDCode, Kitchen, TrialPurpose, PHIPNetWt, ItemTrialNotes, SampleApproval, SampleApprovalDate, SampleApprovalNotes, RecipeDate, Notes"
    strSql_S = strSql_S & " FROM [TRD_RDLog];"
    Set rstT2A = db.OpenRecordset(strSql_S)

    '读取当前主记录关联的所有二级记录
    strSql_S = " SELECT TDPK, RDCode, Kitchen, TrialPurpose, PHIPNetWt, ItemTrialNotes, SampleApproval, SampleApprovalDate, SampleApprovalNotes, RecipeDate, Notes"
    strSql_S = strSql_S & " FROM [TRD_RDLog]"
    strSql_S = strSql_S & " WHERE TRPK = " & lngT1PK & ";"
    Set rstT2 = db.OpenRecordset(strSql_S)

    If Not (rstT2.BOF And rstT2.EOF) Then
        rstT2.MoveLast
        rstT2.MoveFirst
        '遍历所有二级待复制记录
        Do While Not rstT2.EOF
            lngT2PK = rstT2!TDPK
            '写入新的二级记录
            With rstT2A
                .AddNew
                !TRPK = lngT1NewFK
                !RDCode = Nz(rstT2!RDCode, "")
                !Kitchen = Nz(rstT2!Kitchen, "")
                !TrialPurpose = Nz(rstT2!TrialPurpose, "")
                !PHIPNetWt = Nz(rstT2!PHIPNetWt, "")
                !ItemTrialNotes = Nz(rstT2!ItemTrialNotes, "")
                !SampleApproval = Nz(rstT2!SampleApproval, "")
                !SampleApprovalDate = Nz(rstT2!SampleApprovalDate, "")
                !SampleApprovalNotes = Nz(rstT2!SampleApprovalNotes, "")
                !RecipeDate = Nz(rstT2!RecipeDate, "")
                !Notes = Nz(rstT2!Notes, "")
                '其余二级表字段按相同格式补充即可
                .Update
                intRC_CS = intRC_CS + 1
                '获取新生成的二级表主键
                .Bookmark = .LastModified
                lngT2NewFK = !TDPK
            End With

            '===== 复制当前二级记录关联的所有三级表记录 =====
            '打开三级表全量写入集
            strSql_A = "SELECT IRF, TDPK, RawCode, Unit, PQty FROM [TFP_PHIPDtl]"
            Set rstT3A = db.OpenRecordset(strSql_A)
            
            '读取当前二级记录关联的所有三级记录
            strSql_A = "SELECT IRF, RawCode, Unit, PQty FROM [TFP_PHIPDtl] WHERE TDPK = " & lngT2PK & ";"
            Set rstT3 = db.OpenRecordset(strSql_A)

            If Not (rstT3.BOF And rstT3.EOF) Then
                rstT3.MoveLast
                rstT3.MoveFirst
                '遍历所有三级待复制记录
                Do While Not rstT3.EOF
                    lngT3PK = rstT3!IRF
                    '写入新的三级记录
                    With rstT3A
                        .AddNew
                        !TDPK = lngT2NewFK
                        !RawCode = Nz(rstT3!RawCode, "")
                        !Unit = Nz(rstT3!Unit, "")
                        !PQty = Nz(rstT3!PQty, "")
                        '其余三级表字段按相同格式补充即可
                        .Update
                        intRC_CA = intRC_CA + 1
                        '获取新生成的三级表主键（若有四级嵌套可继续沿用该逻辑）
                        .Bookmark = .LastModified
                        lngT3NewFK = !IRF
                    End With
                    rstT3.MoveNext
                Loop
            End If
            '关闭当前二级记录对应的三级记录集，释放资源
            If Not rstT3 Is Nothing Then
                rstT3.Close
                Set rstT3 = Nothing
            End If
            If Not rstT3A Is Nothing Then
                rstT3A.Close
                Set rstT3A = Nothing
            End If
            rstT2.MoveNext
        Loop
    End If

    '===== 复制完成后窗体状态调整 =====
    Me.FFP_PHIPLog.Visible = True
    Me.Label186.Visible = True
    Me.Label193.Visible = True
    Me.Label200.Visible = True
    Me.TrialDate.Locked = False
    Me.TrialBy.Locked = False
    Me.QC.Locked = False
    Me.TrialDate.Value = Null
    Me.TrialBy.Value = Null
    Me.QC.Value = Null

    '弹出复制结果提示
    msg = intRC_CD & " 条主表记录(TRD_RDTrial)添加成功"
    msg = msg & vbCrLf & vbCrLf
    msg = msg & intRC_CS & " 条二级表记录(TRD_RDLOG)添加成功"
    msg = msg & vbCrLf & vbCrLf
    msg = msg & intRC_CA & " 条三级表记录(TFP_PHIPDTL)添加成功"
    msg = msg & vbCrLf & vbCrLf
    msg = msg & "累计新增记录数：" & intRC_CD + intRC_CS + intRC_CA
    MsgBox msg

Cleanup:
    '统一释放所有对象资源
    On Error Resume Next
    If Not rstT3 Is Nothing Then rstT3.Close: Set rstT3 = Nothing
    If Not rstT3A Is Nothing Then rstT3A.Close: Set rstT3A = Nothing
    If Not rstT2 Is Nothing Then rstT2.Close: Set rstT2 = Nothing
    If Not rstT2A Is Nothing Then rstT2A.Close: Set rstT2A = Nothing
    If Not db Is Nothing Then Set db = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "复制出错：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

修复说明 #

• 移除了原代码中未赋值的空SQL执行逻辑，从根源解决3078运行时错误，三级记录循环可完整遍历所有关联条目
• 修正了三级记录计数重复累加的问题，复制结果统计准确
• 增加统一的资源释放逻辑和错误捕获，无论代码运行成功还是出错，都会自动关闭所有打开的记录集、释放数据库对象，不会出现表锁残留
• 修正了原代码中Long类型变量前缀的拼写错误（原误写为Ing，统一改为标准lng前缀），避免后续维护混淆
• 代码结构按主/二/三级记录分层，若后续需要扩展四级、五级嵌套子窗体复制，可直接沿用相同的循环逻辑追加即可

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