[AccessD] DAO rules

[Gustav Brock]

Hi all

I have often promoted DAO rather than lengthy and custom append queries, as the tool to copy a parent record and its child records.
This, I had the chance to expand to also copy subchild records (or grandchildren records if you like) of the child records.

The clever part is, that - apart from the key fields, the subform control name, and the subchild table/query name - specifics like field names are not used:

https://www.experts-exchange.com/questions/29208270/MS-Access-Duplicate-Records-with-Multi-Levels-of-Subforms.html#a43244285

If you can't open the link, code is here:

Private Sub CopyButton_Click()

    Dim rst         As DAO.Recordset
    Dim rstAdd      As DAO.Recordset
    Dim rstSub      As DAO.Recordset
    Dim rstSubAdd   As DAO.Recordset
    Dim fld         As DAO.Field
    Dim Count       As Integer
    Dim CountSub    As Integer
    Dim Item        As Integer
    Dim ItemSub     As Integer
    Dim Bookmark    As Variant
    Dim OldId       As Long
    Dim NewId       As Long
    Dim NewSubId    As Long
    
    ' Copy parent record.
    Set rstAdd = Me.RecordsetClone
    Set rst = rstAdd.Clone
    
    ' Move to current record.
    rst.Bookmark = Me.Bookmark
    OldId = rst!Id.Value
    With rstAdd
        .AddNew
        For Each fld In .Fields
            With fld
                If .Attributes And dbAutoIncrField Then
                    ' Skip Autonumber or GUID field.
                Else
                    .Value = rst.Fields(.Name).Value
                End If
            End With
        Next
        .Update
        ' Pick Id of the new record.
        .MoveLast
        NewId = !Id.Value
    End With
    ' Store location of new record.
    Bookmark = rstAdd.Bookmark
    
    ' Copy child records.
    ' If a subform is present:
    Set rstAdd = Me!subChild.Form.RecordsetClone
    ' If a subform is not present, retrieve records from the child table:
'    Set rstAdd = CurrentDb.OpenRecordset("Select * From tblChild Where FK = " & OldId & "")
    Set rst = rstAdd.Clone

    If rstAdd.RecordCount > 0 Then
        rstAdd.MoveLast
        rstAdd.MoveFirst
    End If
    Count = rstAdd.RecordCount
    For Item = 1 To Count
        With rstAdd
            .AddNew
            For Each fld In .Fields
                With fld
                    If .Attributes And dbAutoIncrField Then
                        ' Skip Autonumber or GUID field.
                    ElseIf .Name = "FK" Then
                        ' Skip master/child field.
                        .Value = NewId
                    Else
                        .Value = rst.Fields(.Name).Value
                    End If
                End With
            Next
            .Update
            ' Pick Id of the new record.
            .MoveLast
            NewSubId = !Id.Value
        End With
        
        ' Copy childchild records.
        Set rstSubAdd = CurrentDb.OpenRecordset("Select * From tblChildChild Where FK = " & rst!Id.Value & "")
        Set rstSub = rstSubAdd.Clone
        
        If rstSubAdd.RecordCount > 0 Then
            rstSubAdd.MoveLast
            rstSubAdd.MoveFirst
        End If
        CountSub = rstSubAdd.RecordCount
        For ItemSub = 1 To CountSub
            With rstSubAdd
                .AddNew
                For Each fld In .Fields
                    With fld
                        If .Attributes And dbAutoIncrField Then
                            ' Skip Autonumber or GUID field.
                        ElseIf .Name = "FK" Then
                            ' Skip master/child field.
                            .Value = NewSubId
                        Else
                            .Value = rstSub.Fields(.Name).Value
                        End If
                    End With
                Next
                .Update
            End With
            rstSub.MoveNext
        Next
        
        rst.MoveNext
    Next
    rstSub.Close
    rstSubAdd.Close
    rst.Close
    rstAdd.Close
    
    ' Move to the new recordcopy.
    Me.Bookmark = Bookmark
    
    Set fld = Nothing
    Set rstSubAdd = Nothing
    Set rstSub = Nothing
    Set rstAdd = Nothing
    Set rst = Nothing

End Sub

/gustav