'Purpose: To copy a table from one database to another.
' Notes: Operates by firstly creating the table in the other database, then
' copies the data across.
'Originally written by Microsoft in VB3.
'Code modified by Allan57 to work in 'MS Access 97 VBA'
'16/01/2009
Dim dbsSource As Database
Dim dbsDestination As Database
Dim strErrorStatement As String
Option Compare Database
Option Explicit
Public Function CreateNewTable(DatabaseSource As Database, DatabaseDestination As Database, TableToCopyFrom As String, TableCreateName As String, CreateFieldIndexs As Boolean) As Boolean
Dim tblCreateNewTable As New TableDef
Dim fldCreateFields As Field
Dim indCreateIndexes As Index
Dim intTableDefCounter As Integer
On Error GoTo CreateNewTableError
NameSearch:
'Search destination Db to see if the create table name already exists:
For intTableDefCounter = 0 To DatabaseDestination.TableDefs.Count - 1
If UCase(DatabaseDestination.TableDefs(intTableDefCounter).Name) = UCase(TableCreateName) Then
If MsgBox(TableCreateName & " already exists, delete it?", vbYesNo) = vbYes Then
DatabaseDestination.TableDefs.Delete TableCreateName
Else
TableCreateName = InputBox("Enter New Table Name:", "User input required")
If TableCreateName = "" Then
GoTo CreateNewTableError
Else
GoTo NameSearch
End If
End If
Exit For
End If
Next
'Strip off owner if necessary:
If InStr(TableCreateName, ".") <> 0 Then
TableCreateName = Mid(TableCreateName, InStr(TableCreateName, ".") + 1, Len(TableCreateName))
End If
tblCreateNewTable.Name = TableCreateName
'Create the fields:
For intTableDefCounter = 0 To DatabaseSource.TableDefs(TableToCopyFrom).Fields.Count - 1
Set fldCreateFields = New Field
fldCreateFields.Name = DatabaseSource.TableDefs(TableToCopyFrom).Fields(intTableDefCounter).Name
fldCreateFields.Type = DatabaseSource.TableDefs(TableToCopyFrom).Fields(intTableDefCounter).Type
fldCreateFields.Size = DatabaseSource.TableDefs(TableToCopyFrom).Fields(intTableDefCounter).Size
fldCreateFields.Attributes = DatabaseSource.TableDefs(TableToCopyFrom).Fields(intTableDefCounter).Attributes
tblCreateNewTable.Fields.Append fldCreateFields
Next
'Create the indexes:
If CreateFieldIndexs = True Then
For intTableDefCounter = 0 To DatabaseSource.TableDefs(TableToCopyFrom).Indexes.Count - 1
Set indCreateIndexes = New Index
indCreateIndexes.Name = DatabaseSource.TableDefs(TableToCopyFrom).Indexes(intTableDefCounter).Name
indCreateIndexes.Fields = DatabaseSource.TableDefs(TableToCopyFrom).Indexes(intTableDefCounter).Fields
indCreateIndexes.Unique = DatabaseSource.TableDefs(TableToCopyFrom).Indexes(intTableDefCounter).Unique
indCreateIndexes.Primary = DatabaseSource.TableDefs(TableToCopyFrom).Indexes(intTableDefCounter).Primary
tblCreateNewTable.Indexes.Append indCreateIndexes
Next
End If
'Append the new table:
DatabaseDestination.TableDefs.Append tblCreateNewTable
CreateNewTable = True
Exit Function
CreateNewTableError:
If Err.Number = 0 Then
strErrorStatement = "Operation Aborted by User"
Else
strErrorStatement = Err.Number & " - " & Err.Description
End If
CreateNewTable = False
End Function
Public Function CopyData(DatabaseSource As Database, DatabaseDestination As Database, TableToCopyFrom As String, TableCreateName As String) As Boolean
Dim rstDatabaseSource As Recordset
Dim rstDatabaseDestination As Recordset
Dim intFieldCounter As Integer
On Error GoTo CopyDataError
Set rstDatabaseSource = dbsSource.OpenRecordset(TableToCopyFrom)
Set rstDatabaseDestination = dbsDestination.OpenRecordset(TableCreateName)
While rstDatabaseSource.EOF = False
rstDatabaseDestination.AddNew
For intFieldCounter = 0 To rstDatabaseSource.Fields.Count - 1
rstDatabaseDestination(intFieldCounter) = rstDatabaseSource(intFieldCounter)
Next
rstDatabaseDestination.Update
rstDatabaseSource.MoveNext
Wend
CopyData = True
Exit Function
CopyDataError:
strErrorStatement = Err.Number & " - " & Err.Description
CopyData = False
End Function
Private Sub Form_Load()
Dim strSourceDatabase As String
Dim strDesinationDatabase As String
Dim strSourceTableNameToCopyFrom As String
Dim strDestinationTableNameToCreate As String
Dim fCreateTableIndexesAsWell As Boolean
On Error Resume Next
strSourceDatabase = "c:\db3.mdb"
strDesinationDatabase = "c:\db2.mdb"
strSourceTableNameToCopyFrom = "Table1"
strDestinationTableNameToCreate = "cTable1"
fCreateTableIndexesAsWell = True
Set dbsSource = OpenDatabase(strSourceDatabase, False, True)
Set dbsDestination = OpenDatabase(strDesinationDatabase, False, False)
If CreateNewTable(dbsSource, dbsDestination, strSourceTableNameToCopyFrom, strDestinationTableNameToCreate, fCreateTableIndexesAsWell) = False Then
MsgBox "Failure Creating Table, Operation Aborted" & vbCrLf & vbCrLf & strErrorStatement
GoTo ExitAndCloseObjectReferences
Exit Sub
End If
If CopyData(dbsSource, dbsDestination, strSourceTableNameToCopyFrom, strDestinationTableNameToCreate) = False Then
MsgBox "Failure Copying Data to Table, Operation Aborted" & vbCrLf & vbCrLf & strErrorStatement
GoTo ExitAndCloseObjectReferences
End If
MsgBox "Success Creating/Copying Table"
ExitAndCloseObjectReferences:
dbsSource.Close
dbsDestination.Close
Set dbsSource = Nothing
Set dbsDestination = Nothing
End Sub
Thank u guys. it helped me in my project.
