具有新主键的重复记录 (VBA)

Posted 2023-05-07

【中文标题】具有新主键的重复记录 (VBA)

【英文标题】：Duplicate Record with New Primary Key (VBA)

【发布时间】：2016-08-29 18:46:10

【问题描述】：

我尝试复制一条非常大的记录，然后打开一个带有新主键 ID 的新版本的表单。这可以在 Access VBA 中完成，而无需遍历所有字段来复制数据吗？

谢谢！

【问题讨论】：

不，您将不得不遍历 VBA 中的所有字段或列出 insert 查询中的所有字段，特别是因为您想跳过复制其中一个。在 VBA 方面，尽管您可以使用 For Each 循环遍历记录集的字段，并且只有一个 If 内部检查跳过主键。

【参考方案1】：

最快最简单的方法是使用DAO和RecordsetClone的形式：

Private Sub cmdDuplicate_Click()

  Dim rstSource   As DAO.Recordset
  Dim rstInsert   As DAO.Recordset
  Dim fld         As DAO.Field

  If Me.NewRecord = True Then Exit Sub

  Set rstInsert = Me.RecordsetClone
  Set rstSource = rstInsert.Clone
  With rstSource
    If .RecordCount > 0 Then
      ' Go to the current record.
      .Bookmark = Me.Bookmark
      With rstInsert
        .AddNew
          For Each fld In rstSource.Fields
            With fld
              If .Attributes And dbAutoIncrField Then
                ' Skip Autonumber or GUID field.
              ElseIf .Name = "SomeFieldToPreset" Then
                rstInsert.Fields(.Name).Value = SomeValue
              ElseIf .Name = "SomeFieldToExclude" Then
                ' Leave blank
              Else
                ' All other fields.
                ' Copy field content.
                rstInsert.Fields(.Name).Value = .Value
              End If
            End With
          Next
        .Update
        ' Go to the new record and sync form.
        .MoveLast
        Me.Bookmark = .Bookmark
        .Close
      End With
    End If
    .Close
  End With

  Set rstInsert = Nothing
  Set rstSource = Nothing

End Sub

这会将表单从当前记录移动到新记录。您可以轻松地对其进行修改以选择新 ID 并使用新记录打开另一个表单。

【讨论】：

非常感谢您提供的源代码。我在复制记录时遇到了同样的问题，这段代码正是我需要的。但只是要补充一点：在 ElseIf 语句中，最后缺少 Then 。如果没有它，我会遇到语法错误（使用 MS Access 2016）。因此，如果有人在此源代码中遇到语法错误，请添加 Then 使其看起来像： ElseIf .Name = "SomeFieldToPreset" Then

【参考方案2】：

查看Duplicate Record命令。您可以直接使用它

或调查由向导生成的代码并为自己定制。如果您的 PK 是这样设置的，那么使用向导的方法将不会复制自动编号 PK。

【讨论】：

请注意，此操作是通过嵌入宏复制和粘贴当前记录来完成的（虽然可以将宏导出到vba）。这意味着如果表单包含隐藏字段，则根本不会复制和粘贴它们！

@willywonka 你所指出的令人惊讶的是，如果一个字段在表单上但不可见，它仍然不会被复制。所以是的，这应该谨慎使用。

如果原始表单基于两个表，这似乎也不起作用。

【参考方案3】：

以下过程使用数组来临时存储记录的字段，然后将这些字段（主键除外）复制到新记录中。为此，只有主键字段可以将索引设置为 No Duplicates。

Sub MoveCustomer()
On Error GoTo Err_MoveCustomer

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim myTable As TableDef
    Dim varCustID As Variant
    Dim Arr() As Variant
    Dim intCount As Integer
    Dim intI As Integer
    Dim strMsg As String

    Set dbs = CurrentDb
    Set myTable = dbs.TableDefs("tblCustomers")
    Set rst = dbs.OpenRecordset("tblCustomers", dbOpenDynaset)

    intCount = myTable.Fields.Count

    ReDim Arr(intCount)

    'ID field is Primary Key rst(0)
    rst.FindFirst "[ID] = 5"

    If rst.NoMatch = False Then
        'Record Found
        intI = 0

        'Temp store Cust Record in Array
        Do Until intI = intCount
            Arr(intI) = rst(intI)
            Debug.Print "Field " & intI & " = " & rst(intI)
            intI = intI + 1
        Loop

        'Copy Array contents into new record
        rst.AddNew

        intI = 0

        Do Until intI = intCount
            'Field 0 is Primary Key, do not copy
            If intI > 0 Then
                rst(intI) = Arr(intI)
            End If

            intI = intI + 1
        Loop

        rst.Update

        rst.Bookmark = rst.LastModified
        varCustID = rst![ID]

        rst.Close
        Set rst = Nothing
        Set dbs = Nothing

        'Additional Code as needed based on varCustID

    Else
        'No Record found
        strMsg = "The specified record was not found."
        MsgBox strMsg, vbInformation, "Aspire - Record not found"

    End If

Exit_MoveCustomer:
    Exit Sub
Err_MoveCustomer:
    strMsg = "The procedure to copy a record into a new record failed."
    MsgBox strMsg, vbInformation, "Aspire - Copy procedure failed."
    Resume Exit_MoveCustomer
End Sub