I understand that DAO does not support the decimal data type, but ADOX does. Here's an updated procedure that uses ADOX instead to copy the schema to a new table.
One interesting point to note: the OLEDB provider for Jet sorts columns alphabetically rather than ordinal, as described in this KB article . I was not interested in maintaining an ordinal position, but you can be, in which case you can update this procedure according to your needs.
In order for the ADOX code version to work, you need to install a link to Microsoft ADO Ext. 2.x for DDL and Security (where x = version number, I used 2.8 to verify this procedure). You will also need a link to ADO.
Public Sub CopySchemaAndData_ADOX(ByVal sourceTableName As String, ByVal destinationTableName As String) On Error GoTo Err_Handler Dim cn As ADODB.Connection Dim cat As ADOX.Catalog Dim sourceTable As ADOX.Table Dim destinationTable As ADOX.Table Set cn = CurrentProject.Connection Set cat = New ADOX.Catalog Set cat.ActiveConnection = cn Set destinationTable = New ADOX.Table destinationTable.Name = destinationTableName Set sourceTable = cat.Tables(sourceTableName) Dim col As ADOX.Column For Each col In sourceTable.Columns Dim newCol As ADOX.Column Set newCol = New ADOX.Column With newCol .Name = col.Name .Attributes = col.Attributes .DefinedSize = col.DefinedSize .NumericScale = col.NumericScale .Precision = col.Precision .Type = col.Type End With destinationTable.Columns.Append newCol Next col Dim key As ADOX.key Dim newKey As ADOX.key Dim KeyCol As ADOX.Column Dim newKeyCol As ADOX.Column For Each key In sourceTable.Keys Set newKey = New ADOX.key newKey.Name = key.Name For Each KeyCol In key.Columns Set newKeyCol = destinationTable.Columns(KeyCol.Name) newKey.Columns.Append (newKeyCol) Next KeyCol destinationTable.Keys.Append newKey Next key cat.Tables.Append destinationTable 'Finally, copy data from source to destination table Dim sql As String sql = "INSERT INTO " & destinationTableName & " SELECT * FROM " & sourceTableName CurrentDb.Execute sql Err_Handler: Set cat = Nothing Set key = Nothing Set col = Nothing Set sourceTable = Nothing Set destinationTable = Nothing Set cn = Nothing If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source End If End Sub
Here is the original DAO procedure
Public Sub CopySchemaAndData_DAO(SourceTable As String, DestinationTable As String) On Error GoTo Err_Handler Dim tblSource As DAO.TableDef Dim fld As DAO.Field Dim db As DAO.Database Set db = CurrentDb Set tblSource = db.TableDefs(SourceTable) Dim tblDest As DAO.TableDef Set tblDest = db.CreateTableDef(DestinationTable) 'Iterate over source table fields and add to new table For Each fld In tblSource.Fields Dim destField As DAO.Field Set destField = tblDest.CreateField(fld.Name, fld.Type, fld.Size) If fld.Type = 10 Then 'text, allow zero length destField.AllowZeroLength = True End If tblDest.Fields.Append destField Next fld 'Handle Indexes Dim idx As Index Dim iIndex As Integer For iIndex = 0 To tblSource.Indexes.Count - 1 Set idx = tblSource.Indexes(iIndex) Dim newIndex As Index Set newIndex = tblDest.CreateIndex(idx.Name) With newIndex .Unique = idx.Unique .Primary = idx.Primary 'Some Indexes are made up of more than one field Dim iIdxFldCount As Integer For iIdxFldCount = 0 To idx.Fields.Count - 1 .Fields.Append .CreateField(idx.Fields(iIdxFldCount).Name) Next iIdxFldCount End With tblDest.Indexes.Append newIndex Next iIndex db.TableDefs.Append tblDest 'Finally, copy data from source to destination table Dim sql As String sql = "INSERT INTO " & DestinationTable & " SELECT * FROM " & SourceTable db.Execute sql Err_Handler: Set fld = Nothing Set destField = Nothing Set tblDest = Nothing Set tblSource = Nothing Set db = Nothing If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source End If End Sub
Tim lentine
source share