Article ID: 108147
Article Last Modified on 1/8/2003
Sub Command1_Click ()
Dim dbsource As database
Dim dbdest As database
' The following hard-coded database names could be changed to
' selections from a text box, list box, or combo box to make the
' program more generic:
Set dbsource = OpenDatabase("c:\vb3\biblio.mdb", True, True)
Set dbdest = OpenDatabase("c:\vb3\test1.mdb", True, False)
Print CopyStruct(dbsource, dbdest, "titles", "ctitles", True)
Print CopyData(dbsource, dbdest, "titles", "ctitles")
dbsource.Close
dbdest.Close
End Sub
'Place the following Function statement on one, single line:
Function CopyStruct (from_db As Database, to_db As Database,
from_nm As String, to_nm As String, create_ind As Integer) As Integer
On Error GoTo CSErr
Dim i As Integer
Dim tbl As New Tabledef 'table object
Dim fld As Field 'field object
Dim ind As Index 'index object
'Search to see if the table exists:
namesearch:
For i = 0 To to_db.TableDefs.Count - 1
If UCase(to_db.TableDefs(i).Name) = UCase(to_nm) Then
If MsgBox(to_nm + " already exists, delete it?", 4) = YES
Then
to_db.TableDefs.Delete to_db.TableDefs(to_nm)
Else
to_nm = InputBox("Enter New Table Name:")
If to_nm = "" Then
Exit Function
Else
GoTo namesearch
End If
End If
Exit For
End If
Next
'Strip off owner if necessary:
If InStr(to_nm, ".") <> 0 Then
to_nm = Mid(to_nm, InStr(to_nm, ".") + 1, Len(to_nm))
End If
tbl.Name = to_nm
'Create the fields:
For i = 0 To from_db.TableDefs(from_nm).Fields.Count - 1
Set fld = New Field
fld.Name = from_db.TableDefs(from_nm).Fields(i).Name
fld.Type = from_db.TableDefs(from_nm).Fields(i).Type
fld.Size = from_db.TableDefs(from_nm).Fields(i).Size
fld.Attributes = from_db.TableDefs(from_nm).Fields(i).Attributes
tbl.Fields.Append fld
Next
'Create the indexes:
If create_ind <> False Then
For i = 0 To from_db.TableDefs(from_nm).Indexes.Count - 1
Set ind = New Index
ind.Name = from_db.TableDefs(from_nm).Indexes(i).Name
ind.Fields = from_db.TableDefs(from_nm).Indexes(i).Fields
ind.Unique = from_db.TableDefs(from_nm).Indexes(i).Unique
If gstDataType <> "ODBC" Then
ind.Primary = from_db.TableDefs(from_nm).Indexes(i).Primary
End If
tbl.Indexes.Append ind
Next
End If
'Append the new table:
to_db.TableDefs.Append tbl
CopyStruct = True
GoTo CSEnd
CSErr:
CopyStruct = False
Resume CSEnd
CSEnd:
End Function
'Place the following Function statement on one, single line:
Function CopyData (from_db As Database, to_db As Database,
from_nm As String, to_nm As String) As Integer
On Error GoTo CopyErr
Dim ds1 As Dynaset, ds2 As Dynaset
Dim i As Integer
Set ds1 = from_db.CreateDynaset(from_nm)
Set ds2 = to_db.CreateDynaset(to_nm)
While ds1.EOF = False
ds2.AddNew
For i = 0 To ds1.Fields.Count - 1
ds2(i) = ds1(i)
Next
ds2.Update
ds1.MoveNext
Wend
CopyData = True
GoTo CopyEnd
CopyErr:
CopyData = False
Resume CopyEnd
CopyEnd:
End Function
Additional query words: 3.00
Keywords: KB108147