Access中带Lookup Field属性的RA表完整复制问题求助

问题说明 #

我有一个名为“RA”的Access表，其中部分字段为Lookup Field（点击单元格弹出下拉框，可从另一表选择多项内容）。需要1:1复制该表及其所有属性（包括Lookup Field的下拉、多选等特性），但现有代码无法复制Lookup属性，求修改。

原代码：

Sub DuplicateRATable()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim index As DAO.Index
    Dim rel As DAO.Relation
    Dim newTableName As String

    ' Set the current database
    Set db = CurrentDb()
    
    ' Define the new table name
    newTableName = "RA_Duplicate"
    
    ' Check if the new table already exists and delete if it does
    On Error Resume Next
    db.TableDefs.Delete newTableName
    On Error GoTo 0
    
    ' Copy the original table
    db.Execute "SELECT * INTO " & newTableName & " FROM RA", dbFailOnError
    
    ' Get the original table definition
    Set tdf = db.TableDefs("RA")
    
    ' Loop through the fields of the original table and copy combo box properties
    For Each fld In tdf.Fields
        On Error Resume Next
        ' Check if the field is a combo box
        If fld.Properties("DisplayControl").Value = acComboBox Then
            Dim prop As DAO.Property
            Dim newFld As DAO.Field
            Set newFld = db.TableDefs(newTableName).Fields(fld.Name)
            
            ' Copy combo box properties
            For Each prop In fld.Properties
                On Error Resume Next
                newFld.Properties(prop.Name).Value = prop.Value
                On Error GoTo 0
            Next prop
        End If
        On Error GoTo 0
    Next fld
    
    ' Copy indexes
    For Each index In tdf.Indexes
        On Error Resume Next
        ' Create a new index
        Dim newIndex As DAO.Index
        Set newIndex = db.TableDefs(newTableName).CreateIndex(index.Name)
        
        ' Add fields to the new index
        For Each fld In index.Fields
            newIndex.Fields.Append newIndex.CreateField(fld.Name)
        Next fld
        
        ' Copy index properties
        newIndex.Primary = index.Primary
        newIndex.Unique = index.Unique
        newIndex.IgnoreNulls = index.IgnoreNulls
        newIndex.Required = index.Required
        
        ' Append the new index to the new table
        db.TableDefs(newTableName).Indexes.Append newIndex
        On Error GoTo 0
    Next index
    
    ' Copy relationships
    For Each rel In db.Relations
        If rel.Table = tdf.Name Or rel.ForeignTable = tdf.Name Then
            On Error Resume Next
            Dim newRel As DAO.Relation
            Set newRel = db.CreateRelation(rel.Name, newTableName, rel.ForeignTable, rel.Attributes)
            
            For Each fld In rel.Fields
                newRel.Fields.Append newRel.CreateField(fld.Name)
                newRel.Fields(fld.Name).ForeignName = fld.ForeignName
            Next fld
            
            db.Relations.Append newRel
            On Error GoTo 0
        End If
    Next rel
    
    MsgBox "The table '" & newTableName & "' has been successfully duplicated."
End Sub

修改后的代码 #

Sub DuplicateRATable_WithLookup()
    Dim db As DAO.Database
    Dim tdfOriginal As DAO.TableDef
    Dim tdfNew As DAO.TableDef
    Dim fldOriginal As DAO.Field
    Dim fldNew As DAO.Field
    Dim idxOriginal As DAO.Index
    Dim idxNew As DAO.Index
    Dim relOriginal As DAO.Relation
    Dim relNew As DAO.Relation
    Dim prop As DAO.Property
    Dim newTableName As String
    
    Set db = CurrentDb()
    newTableName = "RA_Duplicate"
    
    ' 删除已存在的目标表
    On Error Resume Next
    db.TableDefs.Delete newTableName
    db.Relations.Delete newTableName & "_*" ' 清理关联关系
    On Error GoTo 0
    
    ' 创建新表结构（替代SELECT INTO，保留所有字段属性）
    Set tdfOriginal = db.TableDefs("RA")
    Set tdfNew = db.CreateTableDef(newTableName)
    
    ' 复制表属性
    For Each prop In tdfOriginal.Properties
        On Error Resume Next
        tdfNew.Properties(prop.Name).Value = prop.Value
        On Error GoTo 0
    Next prop
    
    ' 逐个复制字段及所有属性（包括Lookup）
    For Each fldOriginal In tdfOriginal.Fields
        ' 创建新字段，匹配原始字段的类型和大小
        Set fldNew = tdfNew.CreateField(fldOriginal.Name, fldOriginal.Type, fldOriginal.Size)
        
        ' 复制字段核心属性
        fldNew.AllowZeroLength = fldOriginal.AllowZeroLength
        fldNew.Required = fldOriginal.Required
        fldNew.DefaultValue = fldOriginal.DefaultValue
        fldNew.ValidationRule = fldOriginal.ValidationRule
        fldNew.ValidationText = fldOriginal.ValidationText
        
        ' 复制Lookup相关属性（关键部分）
        On Error Resume Next
        ' 处理DisplayControl（下拉框）
        If Not IsNull(fldOriginal.Properties("DisplayControl").Value) Then
            fldNew.Properties("DisplayControl").Value = fldOriginal.Properties("DisplayControl").Value
        End If
        ' 处理多值Lookup
        If fldOriginal.Properties("AllowMultipleValues").Value Then
            fldNew.Properties("AllowMultipleValues").Value = True
        End If
        ' 复制RowSource、RowSourceType、BoundColumn等Lookup关键属性
        fldNew.Properties("RowSource").Value = fldOriginal.Properties("RowSource").Value
        fldNew.Properties("RowSourceType").Value = fldOriginal.Properties("RowSourceType").Value
        fldNew.Properties("BoundColumn").Value = fldOriginal.Properties("BoundColumn").Value
        fldNew.Properties("ListWidth").Value = fldOriginal.Properties("ListWidth").Value
        fldNew.Properties("ColumnCount").Value = fldOriginal.Properties("ColumnCount").Value
        fldNew.Properties("ColumnWidths").Value = fldOriginal.Properties("ColumnWidths").Value
        On Error GoTo 0
        
        ' 复制所有其他扩展属性
        For Each prop In fldOriginal.Properties
            On Error Resume Next
            ' 跳过已设置的核心属性，避免重复赋值错误
            Select Case prop.Name
                Case "Name", "Type", "Size", "AllowZeroLength", "Required", "DefaultValue", "ValidationRule", "ValidationText"
                    ' 已手动设置，跳过
                Case Else
                    ' 若属性不存在，先创建再赋值
                    If Not PropertyExists(fldNew, prop.Name) Then
                        Dim newProp As DAO.Property
                        Set newProp = fldNew.CreateProperty(prop.Name, prop.Type, prop.Value)
                        fldNew.Properties.Append newProp
                    Else
                        fldNew.Properties(prop.Name).Value = prop.Value
                    End If
            End Select
            On Error GoTo 0
        Next prop
        
        ' 将新字段添加到表
        tdfNew.Fields.Append fldNew
    Next fldOriginal
    
    ' 复制索引
    For Each idxOriginal In tdfOriginal.Indexes
        Set idxNew = tdfNew.CreateIndex(idxOriginal.Name)
        idxNew.Primary = idxOriginal.Primary
        idxNew.Unique = idxOriginal.Unique
        idxNew.IgnoreNulls = idxOriginal.IgnoreNulls
        
        ' 添加索引字段
        For Each fldOriginal In idxOriginal.Fields
            idxNew.Fields.Append idxNew.CreateField(fldOriginal.Name)
        Next fldOriginal
        
        tdfNew.Indexes.Append idxNew
    Next idxOriginal
    
    ' 将新表添加到数据库
    db.TableDefs.Append tdfNew
    
    ' 复制数据
    db.Execute "INSERT INTO " & newTableName & " SELECT * FROM RA", dbFailOnError
    
    ' 复制关联关系
    For Each relOriginal In db.Relations
        If relOriginal.Table = tdfOriginal.Name Then
            ' 原表作为主表的关系
            Set relNew = db.CreateRelation(relOriginal.Name & "_Copy", newTableName, relOriginal.ForeignTable, relOriginal.Attributes)
            For Each fldOriginal In relOriginal.Fields
                relNew.Fields.Append relNew.CreateField(fldOriginal.Name)
                relNew.Fields(fldOriginal.Name).ForeignName = fldOriginal.ForeignName
            Next fldOriginal
            db.Relations.Append relNew
        ElseIf relOriginal.ForeignTable = tdfOriginal.Name Then
            ' 原表作为子表的关系
            Set relNew = db.CreateRelation(relOriginal.Name & "_Copy", relOriginal.Table, newTableName, relOriginal.Attributes)
            For Each fldOriginal In relOriginal.Fields
                relNew.Fields.Append relNew.CreateField(fldOriginal.Name)
                relNew.Fields(fldOriginal.Name).ForeignName = fldOriginal.ForeignName
            Next fldOriginal
            db.Relations.Append relNew
        End If
    Next relOriginal
    
    MsgBox "表 '" & newTableName & "' 已完整复制，包含所有Lookup属性。"
End Sub

' 辅助函数：检查字段是否存在指定属性
Private Function PropertyExists(fld As DAO.Field, propName As String) As Boolean
    Dim prop As DAO.Property
    On Error Resume Next
    Set prop = fld.Properties(propName)
    PropertyExists = Err.Number = 0
    On Error GoTo 0
End Function

关键修改说明 #

• 替换表创建方式：用CreateTableDef替代SELECT INTO，后者仅复制基础字段结构和数据，不会保留Lookup等扩展属性。
• 完整复制Lookup属性：手动处理DisplayControl、AllowMultipleValues、RowSource、BoundColumn等Lookup核心属性，确保下拉框和多选功能正常。
• 属性存在性检查：新增PropertyExists辅助函数，避免因新字段不存在某属性而报错，不存在则先创建再赋值。
• 严谨的关系复制：区分原表作为主表/子表的关系，避免关系名称冲突。
• 分步操作：先创建表结构、复制属性，再插入数据，确保属性复制不受数据影响。

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