How to copy a database table. This may require some tweaking….
“Bill Pearson”
Original Author: Newsgroup Posting
Code
Private Sub Form_Load()
Dim dbFrom As Database
Dim dbTo As Database
Set dbFrom = workspaces(0).opendatabase("c:vb4iblio.mdb")
Set dbTo = workspaces(0).opendatabase("c:vb4iblio.mdb")
db_Copy_Tabledef dbFrom, dbTo, "Authors", "CopyOfAuthors"
dbFrom.Close
dbTo.Close
End Sub
Public Function db_Copy_Tabledef(dbFrom As Database, dbTo As Database,
TableNameFrom As String, TableNameTo As String) As Boolean
Dim tdFrom As TableDef
Dim tdTo As TableDef
Dim fldFrom As Field
Dim fldTo As Field
Dim ndxFrom As Index
Dim ndxTo As Index
Dim FunctionName As String
Dim Found As Boolean
On Error Resume Next
For Each tdFrom In dbFrom.TableDefs
'-----------------------------
'Loop until find the table def
'-----------------------------
If LCase$(tdFrom.Name) = LCase$(TableNameFrom) Then
Found = True
'----------------------
'Create Table defintion
'----------------------
Set tdTo = dbTo.CreateTableDef(TableNameTo)
'------------------------------
'Copy each field and attributes
'------------------------------
For Each fldFrom In dbFrom.TableDefs(tdFrom.Name).Fields
Set fldTo = tdTo.CreateField(fldFrom.Name)
fldTo.Type = fldFrom.Type
fldTo.DefaultValue = fldFrom.DefaultValue
fldTo.Required = fldFrom.Required
Select Case fldFrom.Type
Case dbText
fldTo.Size = fldFrom.Size
fldTo.Attributes = fldFrom.Attributes
fldTo.AllowZeroLength = fldTo.AllowZeroLength
Case dbMemo
fldTo.AllowZeroLength = fldTo.AllowZeroLength
Case Else
End Select
tdTo.Fields.Append fldTo
If Err.Number > 0 Then
MsgBox "Error adding field to table " & TableNameTo &
".", vbCritical, FunctionName
Exit Function
End If
Next
'-----------------------
'Copy Index defintion(s)
'-----------------------
For Each ndxFrom In dbFrom.TableDefs(tdFrom.Name).Indexes
Set ndxTo = tdTo.CreateIndex(ndxFrom.Name)
ndxTo.Required = ndxFrom.Required
ndxTo.IgnoreNulls = ndxFrom.IgnoreNulls
ndxTo.Primary = ndxFrom.Primary
ndxTo.Clustered = ndxFrom.Clustered
ndxTo.Unique = ndxFrom.Unique
'---------------------
'Copy each index field
'---------------------
For Each fldFrom In
dbFrom.TableDefs(tdFrom.Name).Indexes(ndxFrom.Name).Fields
Set fldTo = ndxTo.CreateField(fldFrom.Name)
ndxTo.Fields.Append fldTo
If Err.Number > 0 Then
MsgBox "Error adding field to index in table " &
TableNameTo & ".", vbCritical, FunctionName
Exit Function
End If
Next
tdTo.Indexes.Append ndxTo
If Err.Number > 0 Then
MsgBox "Error adding index to table " & TableNameTo &
".", vbCritical, FunctionName
Exit Function
End If
Next
dbTo.TableDefs.Append tdTo
If Err.Number > 0 Then
MsgBox "Error adding table " & TableNameTo & ".", vbCritical,
FunctionName
Exit Function
End If
Exit For
End If
Next
If Found Then
db_Copy_Tabledef = True
Else
MsgBox "Table " & TableNameFrom & " not found.", vbExclamation,
FunctionName
End If
On Error GoTo 0
End Function