Solved: Copy tables from one Database to Another Databese in VB (Access)

PING...

1) Create a text file
2) Paste the following into the file
3) Rename the file frmCopyDB.frm
4) Double click on the file
5) Add a project reference to DAO 3.x
6) Hit run.

VERSION 5.00
Begin VB.Form frmMakeBlnk
Caption = "Make Blank Database"
ClientHeight = 5940
ClientLeft = 1140
ClientTop = 1515
ClientWidth = 6690
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 5940
ScaleWidth = 6690
Begin VB.CheckBox chkIndex
Alignment = 1 'Right Justify
Caption = "Copy Indecies"
Height = 300
Left = 1875
TabIndex = 24
Top = 1050
Value = 1 'Checked
Width = 1605
End
Begin VB.CheckBox chkSystem
Alignment = 1 'Right Justify
Caption = "Enabled Security"
Height = 300
Left = 120
TabIndex = 23
Top = 1410
Width = 1605
End
Begin VB.PictureBox picSystem
Height = 735
Left = 120
ScaleHeight = 675
ScaleWidth = 6330
TabIndex = 15
Top = 1770
Visible = 0 'False
Width = 6390
Begin VB.TextBox txtPassword
Height = 285
Left = 3525
TabIndex = 21
Text = "txtPassword"
Top = 345
Width = 1215
End
Begin VB.TextBox txtUserID
Height = 285
Left = 1335
TabIndex = 19
Text = "txtUserID"
Top = 315
Width = 1215
End
Begin VB.TextBox txtSystemDB
Height = 285
Left = 1335
TabIndex = 17
Text = "txtSystemDB"
Top = 30
Width = 4665
End
Begin VB.CommandButton cmd_FindDB
Height = 270
Index = 2
Left = 6000
Picture = "frmMakeBlank.frx":0000
Style = 1 'Graphical
TabIndex = 16
Top = 45
Width = 255
End
Begin VB.Label Label6
Caption = "Password"
Height = 195
Left = 2625
TabIndex = 22
Top = 375
Width = 825
End
Begin VB.Label Label5
Caption = "User ID"
Height = 195
Left = 75
TabIndex = 20
Top = 330
Width = 825
End
Begin VB.Label Label4
Caption = "System DB"
Height = 195
Left = 45
TabIndex = 18
Top = 45
Width = 825
End
End
Begin VB.CheckBox chkVersion
Alignment = 1 'Right Justify
Caption = "Change Version"
Height = 300
Left = 1890
TabIndex = 14
Top = 690
Width = 1605
End
Begin VB.PictureBox picVersion
Height = 495
Left = 3750
ScaleHeight = 435
ScaleWidth = 2625
TabIndex = 11
Top = 660
Visible = 0 'False
Width = 2685
Begin VB.TextBox txtVersion
Height = 360
Left = 1335
TabIndex = 12
Text = "txtVersion"
Top = 45
Width = 1185
End
Begin VB.Label Label3
Caption = "Output Version"
Height = 210
Left = 135
TabIndex = 13
Top = 90
Width = 1275
End
End
Begin VB.CheckBox chkQueries
Alignment = 1 'Right Justify
Caption = "Copy Queries"
Height = 300
Left = 120
TabIndex = 10
Top = 990
Value = 1 'Checked
Width = 1605
End
Begin VB.CheckBox chkCopyData
Alignment = 1 'Right Justify
Caption = "Copy Data"
Height = 300
Left = 120
TabIndex = 9
Top = 660
Width = 1605
End
Begin VB.CommandButton cmd_exit
Caption = "Exit"
Height = 390
Left = 4395
TabIndex = 8
Top = 2580
Width = 2145
End
Begin VB.CommandButton cmd_FindDB
Height = 270
Index = 1
Left = 6180
Picture = "frmMakeBlank.frx":0502
Style = 1 'Graphical
TabIndex = 7
Top = 360
Width = 255
End
Begin VB.CommandButton cmd_FindDB
Height = 270
Index = 0
Left = 6180
Picture = "frmMakeBlank.frx":0A04
Style = 1 'Graphical
TabIndex = 6
Top = 45
Width = 255
End
Begin VB.TextBox txtDestinationDB
Height = 285
Left = 1500
TabIndex = 4
Text = "txtDestinationDB"
Top = 345
Width = 4665
End
Begin VB.TextBox txtSourceDB
Height = 285
Left = 1500
TabIndex = 2
Text = "txtSourceDB"
Top = 30
Width = 4665
End
Begin VB.TextBox Text1
Height = 2730
Left = 150
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 1
Text = "frmMakeBlank.frx":0F06
Top = 2970
Width = 6375
End
Begin VB.CommandButton cmd_Create
Caption = "Copy/Create Blank DB"
Height = 390
Left = 135
TabIndex = 0
Top = 2580
Width = 2145
End
Begin VB.Label Label2
Caption = "Destination Database"
Height = 195
Left = 120
TabIndex = 5
Top = 390
Width = 1245
End
Begin VB.Label Label1
Caption = "Source Database"
Height = 195
Left = 120
TabIndex = 3
Top = 60
Width = 1245
End
End
Attribute VB_Name = "frmMakeBlnk"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim AppTitle$

Function GetDBVersion$(DBName$)

Dim ws As Workspace
Dim sdb As Database

GetDBVersion$ = ""

On Error Resume Next
If chkSystem.Value = 1 Then
DBEngine.SystemDB = txtSystemDB
Set ws = DBEngine.CreateWorkspace("MyWS", txtUserID, txtPassword)
Else
Set ws = Workspaces(0)
End If

If Err > 0 Then
Text1 = "Workspace open error: " + Error$
Exit Function
End If

Set sdb = ws.OpenDatabase(txtSourceDB)
If Err > 0 Then
Text1 = "Database open error: " + Error$
Exit Function
End If

GetDBVersion$ = sdb.Version

End Function

Function Scramble$(Password)
Scramble$ = Password
End Function

Function UnScramble$(ScrambledPassword$)
UnScramble$ = ScrambledPassword$
End Function

Private Sub chkSystem_Click()
If chkSystem.Value = 1 Then
picSystem.Visible = True
Else
picSystem.Visible = False
End If
End Sub

Private Sub chkVersion_Click()
If chkVersion.Value = 1 Then
txtVersion = GetDBVersion(txtSourceDB)
picVersion.Visible = True
Else
picVersion.Visible = False
End If

End Sub

Private Sub cmd_Create_Click()
Dim ok

SaveSetting AppTitle$, "Settings", "SourceDB", txtSourceDB
SaveSetting AppTitle$, "Settings", "DestinationDB", txtDestinationDB

SaveSetting AppTitle$, "Settings", "CopyData", Val(chkCopyData.Value)
SaveSetting AppTitle$, "Settings", "CopyQueries", Val(chkQueries.Value)
SaveSetting AppTitle$, "Settings", "CopyIndex", Val(chkIndex.Value)
SaveSetting AppTitle$, "Settings", "ChangeVersion", Val(chkVersion.Value)
SaveSetting AppTitle$, "Settings", "Version", txtVersion

SaveSetting AppTitle$, "Settings", "EnableSEcurity", Val(chkSystem.Value)
SaveSetting AppTitle$, "Settings", "SystemDB", txtSystemDB
SaveSetting AppTitle$, "Settings", "UserID", txtUserID
SaveSetting AppTitle$, "Settings", "Password", Scramble(txtPassword)

If chkVersion.Value = 1 Then
If InStr("1.0 1.1 2.0 3.0 4.0", txtVersion) = 0 Then
MsgBox "DB Version must be either: 1.0, 1.1, 2.0, 3.0 or 4.0", vbExclamation, "Error"
txtVersion.SetFocus
Exit Sub
End If
End If

If Len(Dir$(txtDestinationDB)) > 0 Then
ok = MsgBox("Destination DB already exists. Overwrite Y/N", vbYesNo + vbExclamation, "Create Blank DB")
If ok <> vbYes Then Exit Sub
End If
Dim sourcedb$
Dim outputdb$
Dim tempfile$

Dim tbdef As TableDef
Dim sdef As TableDef
Dim tc As Integer
Dim fld As Field
Dim sfld As Field
Dim ind As Index
Dim tbn$

Dim srs As Recordset
Dim ors As Recordset

Dim sdb As Database
Dim odb As Database

Dim fc As Integer
Dim dn$
Dim IC As Integer
Dim er$, mes$

Dim otb As Recordset
Dim stb As Recordset

ReDim oflds(0) As Field
ReDim cflds(0) As Field
Dim qdef As QueryDef
Dim oqdef As QueryDef
Dim NewVersion
Dim df As Integer
Dim sql$
Dim datadir$
Dim DBName$
Dim oldversion$

sourcedb$ = txtSourceDB
outputdb$ = txtDestinationDB
Text1 = ""

Screen.MousePointer = vbHourglass

Set sdb = Workspaces(0).OpenDatabase(sourcedb$)

On Error Resume Next
If Len(Dir(outputdb$)) > 0 Then
Kill outputdb$
End If
On Error GoTo 0
If chkVersion.Value = 1 Then
oldversion$ = txtVersion
Else
oldversion$ = sdb.Version
End If
Select Case oldversion$
Case Is = "1.1": NewVersion = dbVersion11
Case Is = "2.0": NewVersion = dbVersion20
Case Is = "1.0": NewVersion = dbVersion10
Case Is = "3.0": NewVersion = dbVersion30
Case Is = "4.0": NewVersion = dbVersion40
Case Else
MsgBox txtSourceDB + " is a V" + sdb.Version + " database and cannot be converted to version " + oldversion$, vbExclamation, "Error"
Exit Sub

End Select
'NewVersion = dbVersion20
Set odb = Workspaces(0).CreateDatabase(outputdb$, dbLangGeneral, NewVersion)

For tc = 0 To sdb.TableDefs.Count - 1

Set sdef = sdb.TableDefs(tc)
'sdef.sourcetablename
If Len(sdef.Connect) = 0 Then
If Left(sdef.Name, 4) <> "MSys" And Left(sdef.Name, 1) <> "~" Then
Set tbdef = odb.CreateTableDef(sdb.TableDefs(tc).Name)
Text1.SelStart = Len(Text1)
Text1.SelText = sdef.Name + vbCrLf

For fc = 0 To sdef.Fields.Count - 1

Set fld = New Field
Set sfld = sdef.Fields(fc)

'tbdef.CreateField(sdef.Fields(fc).Name, sdef.Fields(fc).Type, sdef.Fields(fc).Size)
fld.Name = sfld.Name
On Error Resume Next
Err = 0
fld.Type = sfld.Type

If Err <> 0 Then
fld.Type = dbText
End If
On Error GoTo 0

fld.Size = sfld.Size
fld.attributes = sfld.attributes

fld.DefaultValue = sfld.DefaultValue

fld.ForeignName = sfld.OrdinalPosition
fld.Required = sfld.Required
fld.ValidationRule = sfld.ValidationRule
fld.ValidationText = sfld.ValidationText

tbdef.Fields.Append fld

Next fc
' End If

odb.TableDefs.Append tbdef
End If
End If
Next tc

' Now create indexes
If chkIndex.Value = 1 Then

For tc = 0 To sdb.TableDefs.Count - 1

Set sdef = sdb.TableDefs(tc)
If Len(sdef.Connect) = 0 Then
If Left(sdef.Name, 4) <> "MSys" Then
For fc = 0 To sdef.Indexes.Count - 1

Set ind = New Index

ind.Name = sdef.Indexes(fc).Name
ind.Fields = sdef.Indexes(fc).Fields
ind.Unique = sdef.Indexes(fc).Unique
ind.Primary = sdef.Indexes(fc).Primary
ind.IgnoreNulls = sdef.Indexes(fc).IgnoreNulls
ind.Required = sdef.Indexes(fc).Required
On Error Resume Next
Err = 0
odb.TableDefs(sdef.Name).Indexes.Append ind
If Err Then
tbn$ = sdef.Name
mes$ = "Index: " + ind.Name + " " + Error$
GoSub storeerror
End If
On Error GoTo 0
Next fc
End If
End If
ok = DoEvents()
Next tc

End If

If chkQueries.Value = 1 Then

' Transfer queries
For tc = 0 To sdb.QueryDefs.Count - 1
Set qdef = New QueryDef
Set oqdef = sdb.QueryDefs(tc)
qdef.Connect = oqdef.Connect
' qdef.DateCreated = oqdef.DateCreated
' qdef.DateCreated = oqdef.DateCreated
' qdef.LastUpdated = oqdef.LastUpdated
' qdef.LogMessages = oqdef.LogMessages
qdef.Name = oqdef.Name
qdef.ODBCTimeout = qdef.ODBCTimeout
' qdef.RecordsAffected = oqdef.RecordsAffected
qdef.ReturnsRecords = oqdef.ReturnsRecords
qdef.sql = oqdef.sql
' qdef.Type = oqdef.Type
' qdef.Updatable = oqdef.Updatable
On Error Resume Next
odb.QueryDefs.Append qdef
On Error GoTo 0
Next tc

End If

'pok=msgbox "copy tables"
If chkCopyData.Value = 1 Then

For tc = 0 To sdb.TableDefs.Count - 1
tbn$ = sdb.TableDefs(tc).Name
If UCase$(Left$(tbn$, 4)) <> "MSYS" And UCase$(Left$(tbn$, 4)) <> "~TMP" Then

sql$ = "INSERT INTO [" + outputdb$ + "].[" + tbn$ + "]"
sql$ = sql$ + " SELECT [" + tbn$ + "].*"
sql$ = sql$ + " FROM [" + tbn$ + "];"

sdb.Execute sql$

'OpenRecordset(sql$, dbOpenSnapshot)
'Set ors = sdb.OpenRecordset(sql$, dbOpenDynaset, dbAppendOnly)
'If srs.RecordCount > 0 Then
' srs.MoveFirst
' Do While Not srs.EOF
' ors.AddNew
' For fc = 0 To srs.Fields.Count - 1
' ors(srs(fc).Name) = srs(fc)
' Next fc
' ors.Update
' srs.MoveNext
' Loop
'End If
End If
Next tc

End If

odb.Close
sdb.Close

Screen.MousePointer = vbDefault
Text1.SelStart = Len(Text1)
Text1.SelText = er$ + vbCrLf

MsgBox "Create Blank DB Done", vbInformation, "Create Blank DB"

Exit Sub

storeerror:
er$ = er$ + tbn$ + " " + mes$ + vbCrLf
Return

End Sub

Private Sub cmd_Exit_Click()
Unload Me
End Sub

Private Sub cmd_FindDB_Click(Index As Integer)

Dim FileName$
Dim SearchPath$
Dim FilterDetails$
Dim DefaultFilter As Long
Dim DefaultExt$
Dim Flags As Long
Dim FS As New cFS
Dim title$
Dim dfilter$
Dim fmode$

Select Case Index
Case Is = 0
FileName = txtSourceDB: title$ = "Select the Source DB": fmode$ = "Open"
Flags = cdlOFNFileMustExist And _
cdlOFNHideReadOnly And _
cdlOFNLongNames And _
cdlOFNPathMustExist And _
cdlOFNShareAware

Case Is = 1
FileName = txtDestinationDB: title$ = "Select the Destination DB ": fmode$ = "Save As"
Flags = cdlOFNHideReadOnly And _
cdlOFNOverwritePrompt And _
cdlOFNLongNames And _
cdlOFNPathMustExist

Case Is = 2
FileName = txtSystemDB: title$ = "Select the System DB ": fmode$ = "Save As"
Flags = cdlOFNHideReadOnly And _
cdlOFNOverwritePrompt And _
cdlOFNLongNames And _
cdlOFNPathMustExist

End Select

SearchPath$ = FS.GetFolderName(FileName$)

'cdlOFNAllowMultiselect ' allows multiple selections
'cdlOFNCreatePrompt ' Must be New File - auto sets cdlOFNPathMustExist and cdlOFNFileMustExist
'cdlOFNExplorer ' Explorer-like Open A File - Works with Windows 95 and Windows NT 4.0
'CdlOFNExtensionDifferent ' returned filename ext different from DefaultExt property
'cdlOFNFileMustExist ' auto sets the cdlOFNPathMustExist flag
'cdlOFNHelpButton ' Causes the dialog box to display the Help button
'cdlOFNHideReadOnly 'Hides the Read Onlycheck box
'cdlOFNLongNames ' Use long filenames
'cdlOFNNoChangeDir ' Only select from Current dir
'CdlOFNNoDereferenceLinks ' choosing a shell link causes it to be dereferenced by the shell
'cdlOFNNoLongNames ' No long file names.
'CdlOFNNoReadOnly ' Cant have Read Only and won't be in a write-protected directory
'cdlOFNNoValidate ' Allows invalid characters in the returned filename
'cdlOFNOverwritePrompt ' Save As dialog box to generate a message box if the selected file already exists. The user must confirm whether to overwrite the file
'cdlOFNPathMustExist ' Specifies that the user can enter only valid paths
'cdlOFNReadOnly ' Causes the Read Only check box to be initially checked when the dialog box is created. This flag also indicates the state of the Read Only check box when the dialog box is closed
'cdlOFNShareAware ' Specifies that sharing violation errors will be ignored.

'cdlOFNEExplorer And _
' see CommonDialog.Filter for details
If Index = 2 Then
FilterDetails = "System Database Files (*.MDA)"
dfilter$ = "*.MDA"
Else
FilterDetails = "Database Files (*.MDB)"
dfilter$ = "*.MDB"
End If
DefaultFilter = 1

FileName$ = GetFileName(FileName$, fmode$, title$, SearchPath$, dfilter$, Flags, FilterDetails$, DefaultFilter)

If Len(FileName$) > 0 Then

Select Case Index
Case Is = 0
txtSourceDB = FileName
chkVersion_Click
Case Is = 1
txtDestinationDB = FileName
End Select

End If
End Sub

Private Sub Form_Load()

AppTitle$ = "Make Blank DB"
txtSourceDB = GetSetting(AppTitle$, "Settings", "SourceDB", "")
txtDestinationDB = GetSetting(AppTitle$, "Settings", "DestinationDB", "")
Text1 = ""

chkCopyData.Value = Val(GetSetting(AppTitle$, "Settings", "CopyData", "0"))
chkQueries.Value = Val(GetSetting(AppTitle$, "Settings", "CopyQueries", "1"))
chkIndex.Value = Val(GetSetting(AppTitle$, "Settings", "Index", "1"))
chkVersion.Value = Val(GetSetting(AppTitle$, "Settings", "ChangeVersion", "0"))
txtVersion = Val(GetSetting(AppTitle$, "Settings", "Version", "3.0"))
chkIndex.Value = Val(GetSetting(AppTitle$, "Settings", "Index", "1"))

chkSystem.Value = Val(GetSetting(AppTitle$, "Settings", "EnableSecurity", "0"))

txtSystemDB = GetSetting(AppTitle$, "Settings", "SystemDB", "")
txtUserID = GetSetting(AppTitle$, "Settings", "UserID", "")
txtPassword = UnScramble(GetSetting(AppTitle$, "Settings", "Password", ""))
chkSystem_Click
chkVersion_Click

End Sub

Private Sub Form_Resize()
Dim tw As Single
tw = Me.ScaleWidth - cmd_FindDB(0).Width - txtSourceDB.Left
If tw < 0 Then Exit Sub

txtSourceDB.Width = tw
cmd_FindDB(0).Left = tw + txtSourceDB.Left
cmd_FindDB(1).Left = tw + txtDestinationDB.Left
txtDestinationDB.Width = tw

End Sub

Private Sub txtSourceDB_LostFocus()
chkVersion_Click
End Sub

RichW

'You can use ADOX. ADOX allows you to grab the fields, tables,
'etc. of Access db's. You create a Catalog, which stores all the
'information about the tables.

'Declarations

Option Explicit

'Properties of the Catalog
Private Catalog As ADOX.Catalog
Private Col As ADOX.Column
Private Cols As ADOX.Columns
Private Grp As ADOX.Group
Private Grps As ADOX.Groups
Private Ndx As ADOX.Index
Private Ndxs As ADOX.Indexes
Private Key As ADOX.Key
Private Keys As ADOX.Keys
Private Proc As ADOX.Procedure
Private Procs As ADOX.Procedures
Private Prop As ADOX.Property
Private Props As ADOX.Properties
Private Table As ADOX.Table
Private Tables As ADOX.Tables
Private User As ADOX.User
Private Users As ADOX.Users
Private View As ADOX.View
Private Views As ADOX.Views

Public Enum TblProps
tblTempTable = 0
tblValidationText = 1
tblValidationRule = 2
tblCacheLinkNamePassword = 3
tblRemoteTableName = 4
tblLinkProviderString = 5
tblLinkDataSource = 6
tblExclusiveLink = 7
tblCreateLink = 8
tblTableHiddenInAccess = 9
End Enum

Public Enum ColProps
colAutoincrement = 0
colDefault = 1
colDescription = 2
colNullable = 3
colFixedLength = 4
colSeed = 5
colIncrement = 6
colValidationText = 7
colValidationRule = 8
colIISNotLastColumn = 9
colAutoGenerate = 10
colOneBlobPerPage = 11
colCompressedUnicode = 12
colAllowZeroLength = 13
colHyperlink = 14
End Enum

'Code

Public Function ColumnFormat(TableName As String, Column As Variant) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler

Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)

ColumnFormat = NumberFormat(Col.Type)
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnFormat = ""
Resume ExitHere
End Function

Public Function ColumnProperty(TableName As String, Column As Variant, Property As ColProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler

Set Table = Tables(TableName)
Set Cols = Table.Columns
Set Col = Cols(Column)

ColumnProperty = Col.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Cols = Nothing
Set Col = Nothing
Exit Function
ErrHandler:
ColumnProperty = ""
Resume ExitHere
End Function

Public Function TableProperty(TableName As String, Property As TblProps) As Variant
'return variant because we do not
'know the type of data that is going
'to be returned to calling method
On Error GoTo ErrHandler

Set Table = Tables(TableName)
Set Props = Table.Properties
TableProperty = Table.Properties(Property).Value
ExitHere:
Set Table = Nothing
Set Props = Nothing
Exit Function
ErrHandler:
TableProperty = Nothing
Resume ExitHere
End Function

Private Function NumberFormat(ColType As ADODB.DataTypeEnum) As String
Select Case ColType
Case adEmpty ' 0 - No value was specified (DBTYPE_EMPTY).
Case adSmallInt: NumberFormat = "General Number" ' 2 - A 2-byte signed integer (DBTYPE_I2).
Case adInteger: NumberFormat = "General Number" ' 3 - A 4-byte signed integer (DBTYPE_I4).
Case adSingle: NumberFormat = "General Number" ' 4 - A single-precision floating point value (DBTYPE_R4).
Case adDouble: NumberFormat = "General Number" ' 5 - A double-precision floating point value (DBTYPE_R8).
Case adCurrency: NumberFormat = "Currency" ' 6 - A currency value (DBTYPE_CY). Currency is a fixed-point number with four digits to the right of the decimal point. It is stored in an 8-byte signed integer scaled by 10,000.
Case adDate: NumberFormat = "General Date" ' 7 - A Date value (DBTYPE_DATE). A date is stored as a Double, the whole part of which is the number of days since December 30, 1899, and the fractional part of which is the fraction of a day.
Case adBSTR ' 8 - A null-terminated character string (Unicode) (DBTYPE_BSTR).
Case adIDispatch ' 9 - A pointer to an IDispatch interface on an OLE object (DBTYPE_IDISPATCH).
Case adError ' 10 - A 32-bit error code (DBTYPE_ERROR).
Case adBoolean: NumberFormat = "True/False" ' 11 - A Boolean value (DBTYPE_BOOL).
Case adVariant ' 12 - An Automation Variant (DBTYPE_VARIANT).
Case adIUnknown ' 13 - A pointer to an IUnknown interface on an OLE object (DBTYPE_IUNKNOWN).
Case adDecimal: NumberFormat = "Standard" ' 14 - An exact numeric value with a fixed precision and scale (DBTYPE_DECIMAL).
Case adTinyInt: NumberFormat = "General Number" ' 16 - A 1-byte signed integer (DBTYPE_I1).
Case adUnsignedTinyInt: NumberFormat = "General Number" ' 17 - A 1-byte unsigned integer (DBTYPE_UI1).
Case adUnsignedSmallInt: NumberFormat = "General Number" ' 18 - A 2-byte unsigned integer (DBTYPE_UI2).
Case adUnsignedInt: NumberFormat = "General Number" ' 19 - A 4-byte unsigned integer (DBTYPE_UI4).
Case adUnsignedBigInt: NumberFormat = "General Number" ' 21 - An 8-byte unsigned integer (DBTYPE_UI8).
Case adBigInt: NumberFormat = "General Number" ' 20 - An 8-byte signed integer (DBTYPE_I8).
Case adGUID ' 72 - A globally unique identifier (GUID) (DBTYPE_GUID).
Case adBinary '128 - A binary value (DBTYPE_BYTES).
Case adChar '129 - A String value (DBTYPE_STR).
Case adWChar '130 - A null-terminated Unicode character string (DBTYPE_WSTR).
Case adNumeric: NumberFormat = "General Number" '131 - An exact numeric value with a fixed precision and scale (DBTYPE_NUMERIC).
Case adUserDefined '132 - A user-defined variable (DBTYPE_UDT).
Case adDBDate: NumberFormat = "General Date" '133 - A date value (yyyymmdd) (DBTYPE_DBDATE).
Case adDBTime: NumberFormat = "Long Time" '134 - A time value (hhmmss) (DBTYPE_DBTIME).
Case adDBTimeStamp: NumberFormat = "General Date" '135 - A date-time stamp (yyyymmddhhmmss plus a fraction in billionths) (DBTYPE_DBTIMESTAMP).
Case adVarChar '200 - A String value (Parameter object only).
Case adLongVarChar '201 - A long String value (Parameter object only).
Case adVarWChar '202 - A null-terminated Unicode character string (Parameter object only).
Case adLongVarWChar '203 - A long null-terminated string value (Parameter object only).
Case adVarBinary '204 - A binary value (Parameter object only).
Case adLongVarBinary '205 - A long binary value (Parameter object only).
End Select
End Function

Private Function SetCatalog() As ADOX.Catalog
'Retrieves the description of the field
'Cat.Tables(1).Columns(1).Properties(2).Value
'Set DBCatalog = Cat
'Set Cat = Nothing
If Not Catalog Is Nothing Then
End If
End Function

Private Sub Class_Initialize()
'Create the Catlog
Set Catalog = New ADOX.Catalog
Catalog.ActiveConnection = cnADO
Set Tables = Catalog.Tables
Set Users = Catalog.Users
Set Views = Catalog.Views
Set Procs = Catalog.Procedures
Set Grps = Catalog.Groups
End Sub

Private Sub Class_Terminate()
Set Col = Nothing
Set Cols = Nothing
Set Grp = Nothing
Set Grps = Nothing
Set Ndx = Nothing
Set Ndxs = Nothing
Set Key = Nothing
Set Keys = Nothing
Set Proc = Nothing
Set Procs = Nothing
Set Prop = Nothing
Set Props = Nothing
Set Table = Nothing
Set Tables = Nothing
Set User = Nothing
Set Users = Nothing
Set View = Nothing
Set Views = Nothing
Set Catalog = Nothing
End Sub

puloy

ASKER

I need a most simple way to do it...
Like to open two ADODB.Connectins...and do a SELECT from one database to the other...

like "INSERT INTO ACCESS2.tblITEMLS SELECT * from ACCESS1.tblItems "

or something like that...

inthedark

If you wan't to use ADODB then RichW proposes ADOX which is very simple to use. The problem with using ADO is that the syntax is not very well defined for non-SQL server database and you can spend a lot of time hunting for answers.

But using good old DAO you could do it with a simple sql statement and use the IN clause.

Select * Into [YourNewTable] from [YourOLDTable] In "C:\YourOtherDB.MDB"

But I don't think that ADO supports IN.

Using ADO You can select different database using dots:

Select * Into MydataBase.DBO.[MyNewTable] From MyOldDB.DBO.[MyOldTable]

But I don't think that ADO supports MyOldDB.DBO syntax.

Scratches head and thinks......

talluri_28

hi puloy,

i hope this piece of code will help u. i think this the minimum code that can be written to solve u r problem.

Private Sub TableInsert()
Dim ConOldDb As New ADODB.Connection
Dim ConNewDb As New ADODB.Connection
Dim rsold As New ADODB.Recordset

ConOldDb.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\WINDOWS\Desktop\OldDb.mdb;Persist Security Info=False"
ConNewDb.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\WINDOWS\Desktop\NewDb.mdb;Persist Security Info=False"
rsold.CursorLocation = adUseClient
rsold.Open "Select * from student", ConOldDb
If rsold.RecordCount <> 0 Then
Do While rsold.EOF = False
strinsert = ""
For i = 0 To rsold.Fields.Count - 1
If rsold.Fields(i).Type = adNumeric Then
strinsert = strinsert & rsold.Fields(i).Value & ","
Else
strinsert = strinsert & "'" & rsold.Fields(i).Value & "',"
End If
Next
strinsert = Left(strinsert, Len(strinsert) - 1)
ConNewDb.Execute "Insert Into Student Values (" & strinsert & ")"
rsold.MoveNext
Loop
End If
rsold.Close
ConOldDb.Close
ConNewDb.Close

End Sub

RichW

inthedark, what's wrong with ADO syntax??? I believe if you're using an MS DB product ADO is the way to go.

DAO is good for something like Sybase, because the Sybase drivers are based on DAO.

ADO's buffering is internal, whereas DAO doesn't handle buffering as well. In fact, I had to develop an object based on DAO once, because we had to create a buffering method that would release memory a lot quicker than DAO allowed. Again, with ADO it's all internal.

ADO is a combination of DAO and RDO. They kept the good things, got rid the pita's, and added some more robust functionality.

I also believe the syntax is a lot less difficult than DAO.

I guess it's just a matter of preference.

Regards,
RichW

puloy

ASKER

RichW....
if i do it in your way....i want to copy 4 tables (of 10) to another database....
how do i do that?
it has to be automatically...the user will only click a button in a Form, and the application will always copy the same tables.

it's something like a back-up thing....

inthedark

Yes I agree with you RichW ADOX almost is self documenting. But its when you come to creating recordsets that I have problems - are you aware of any specific Syntax for ADO queries when linking to Access databases?

puloy

ASKER

RichW.....that code will copy all the tables??

how do i choose wich tables to copy??

inthedark

Yes I agree with you RichW ADOX almost is self documenting. But its when you come to creating recordsets that I have problems - are you aware of any specific Syntax for ADO queries when linking to Access databases?

Moondancer

ADMINISTRATION WILL BE CONTACTING YOU SHORTLY. Moderators Computer101, Netminder or Mindphaser will return to finalize these if they are still open in 7 days. Experts, please post closing recommendations before that time.

Below are your open questions as of today. Questions which have been inactive for 21 days or longer are considered to be abandoned and for those, your options are:
1. Accept a Comment As Answer (use the button next to the Expert's name).
2. Close the question if the information was not useful to you, but may help others. You must tell the participants why you wish to do this, and allow for Expert response. This choice will include a refund to you, and will move this question to our PAQ (Previously Asked Question) database. If you found information outside this question thread, please add it.
3. Ask Community Support to help split points between participating experts, or just comment here with details and we'll respond with the process.
4. Delete the question (if it has no potential value for others).
--> Post comments for expert of your intention to delete and why
--> YOU CANNOT DELETE A QUESTION with comments; special handling by a Moderator is required.

For special handling needs, please post a zero point question in the link below and include the URL (question QID/link) that it regards with details.
https://www.experts-exchange.com/jsp/qList.jsp?ta=commspt

Please click this link for Help Desk, Guidelines/Member Agreement and the Question/Answer process. https://www.experts-exchange.com/jsp/cmtyHelpDesk.jsp

Click you Member Profile to view your question history and please keep them updated. If you are a KnowledgePro user, use the Power Search option to find them.

Questions which are LOCKED with a Proposed Answer but do not help you, should be rejected with comments added. When you grade the question less than an A, please comment as to why. This helps all involved, as well as others who may access this item in the future. PLEASE DO NOT AWARD POINTS TO ME.

To view your open questions, please click the following link(s) and keep them all current with updates.
https://www.experts-exchange.com/questions/Q.20275994.html
https://www.experts-exchange.com/questions/Q.20283228.html
https://www.experts-exchange.com/questions/Q.20285708.html
https://www.experts-exchange.com/questions/Q.20286107.html
https://www.experts-exchange.com/questions/Q.20287225.html
https://www.experts-exchange.com/questions/Q.20292488.html
https://www.experts-exchange.com/questions/Q.20295716.html
https://www.experts-exchange.com/questions/Q.20295660.html

***** E X P E R T S P L E A S E ****** Leave your closing recommendations.
If you are interested in the cleanup effort, please click this link
https://www.experts-exchange.com/jsp/qManageQuestion.jsp?ta=commspt&qid=20274643
POINTS FOR EXPERTS awaiting comments are listed in the link below
https://www.experts-exchange.com/commspt/Q.20277028.html

Moderators will finalize this question if in @7 days Asker has not responded. This will be moved to the PAQ (Previously Asked Questions) at zero points, deleted or awarded.

Thanks everyone.
Moondancer
Moderator @ Experts Exchange

DanRollins

Hi puloy,
It appears that you have forgotten this question. I will ask Community Support to close it unless you finalize it within 7 days. I will ask a Community Support Moderator to:

Accept RichW's comment(s) as an answer.

puloy, if you think your question was not answered at all or if you need help, just post a new comment here; Community Support will help you. DO NOT accept this comment as an answer.

EXPERTS: If you disagree with that recommendation, please post an explanatory comment.
==========
DanRollins -- EE database cleanup volunteer

kodiakbear

Moving to the PAQ

kb
Experts Exchange Moderator