CopyTable

Private Sub Form_Load()
Dim dbFrom As Database
Dim dbToAs Database
Set dbFrom = workspaces(0).opendatabase("c:\vb4\biblio.mdb")
Set dbTo = workspaces(0).opendatabase("c:\vb4\biblio.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 tdFromAs TableDef
Dim tdTo As TableDef
Dim fldFrom As Field
Dim fldToAs Field
Dim ndxFrom As Index
Dim ndxToAs Index
Dim FunctionName As String
Dim FoundAs 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