Solved

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

Posted on 2002-04-06
15
914 Views
Last Modified: 2012-08-14
I need to open 2 access databases in Visual Basic and copy somo tables from one to other. HOW DO I DO THIS?

Thanks
0
Comment
Question by:puloy
  • 4
  • 3
  • 3
  • +5
15 Comments
 
LVL 1

Expert Comment

by:COAtheGREAT
Comment Utility
PING...
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
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


0
 
LVL 4

Expert Comment

by:RichW
Comment Utility
'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
0
 

Author Comment

by:puloy
Comment Utility
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...
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
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......

0
 

Expert Comment

by:talluri_28
Comment Utility
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
0
 
LVL 4

Expert Comment

by:RichW
Comment Utility
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
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:puloy
Comment Utility
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....
0
 
LVL 4

Accepted Solution

by:
RichW earned 150 total points
Comment Utility
Set a reference for Microsoft ADO Ext. 2.6 for DDL and Security.
Substitute your dbs in the connections.

This will copy tables from one db to another.

You can modify my code with If statements to search for the tables you want to copy.

I just wrote this and it works.

This will create a catalog, which will then grab the tables from one db and create them in the other db.

Once they're created you can use an INSERT INTO sql statement to populate the tables.

Dim cat As New ADOX.Catalog
Dim cat2 As New ADOX.Catalog
Dim cnn As ADODB.Connection
Dim cnn2 As ADODB.Connection
Dim col As ADOX.Columns
Dim X As Integer
Dim i As Integer


Dim tbl As New Table
Set cat = New ADOX.Catalog
Set cat2 = New ADOX.Catalog
Set cnn = New ADODB.Connection
Set cnn2 = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\0\" & _
       "Binput11602.mdb"
cnn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\acc_li\" & _
       "test.mdb"
cat.ActiveConnection = cnn
cat2.ActiveConnection = cnn2

For X = 0 To cat.Tables.Count - 1
    If Mid(cat.Tables(X).Name, 1, 4) <> "MSys" Then ' Rule out system tables
        tbl.Name = cat.Tables(X).Name
        For i = 0 To cat.Tables(X).Columns.Count - 1
                With tbl
                    .Name = cat.Tables(X).Name
                    .Columns.Append cat.Tables(X).Columns(i).Name, cat.Tables(X).Columns(i).Type
                End With
        Next
        cat2.ActiveConnection = cnn2
        cat2.Tables.Append tbl
        Set cat2 = Nothing
        Set tbl = Nothing
    End If
Next
cnn.Close
cnn2.Close
Set cnn = Nothing
Set cnn2 = Nothing
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
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?

 
0
 

Author Comment

by:puloy
Comment Utility
RichW.....that code will copy all the tables??

how do i choose wich tables to copy??
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
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?

 
0
 
LVL 1

Expert Comment

by:Moondancer
Comment Utility
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.
http://www.experts-exchange.com/jsp/qList.jsp?ta=commspt
 
Please click this link for Help Desk, Guidelines/Member Agreement and the Question/Answer process.  http://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.
http://www.experts-exchange.com/questions/Q.20275994.html
http://www.experts-exchange.com/questions/Q.20283228.html
http://www.experts-exchange.com/questions/Q.20285708.html
http://www.experts-exchange.com/questions/Q.20286107.html
http://www.experts-exchange.com/questions/Q.20287225.html
http://www.experts-exchange.com/questions/Q.20292488.html
http://www.experts-exchange.com/questions/Q.20295716.html
http://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
http://www.experts-exchange.com/jsp/qManageQuestion.jsp?ta=commspt&qid=20274643
POINTS FOR EXPERTS awaiting comments are listed in the link below
http://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
0
 
LVL 49

Expert Comment

by:DanRollins
Comment Utility
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
0
 
LVL 1

Expert Comment

by:kodiakbear
Comment Utility
Moving to the PAQ

kb
Experts Exchange Moderator
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Suggested Solutions

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now