Option Explicit
'***************************************************************
'        (C) Francisco García Aguado, Junio de 2002            *
'***************************************************************


Sub CopiaObjetos(strSourceFile As String, strDestFile As String)
     
     Dim dbsSRC As Database, dbsDest As Database
        
     On Error GoTo errExists
    
     Set dbsSRC = DBEngine.Workspaces(0).OpenDatabase(strSourceFile)
     Set dbsDest = DBEngine.Workspaces(0).OpenDatabase(strDestFile)
     On Error GoTo 0

     CopyTables dbsSRC, dbsDest 'Copio tablas y estructura, excepto las del Sistema
     CopyQueries dbsSRC, dbsDest 'Copio posibles consultas de Seleccion
     CopyData dbsSRC, dbsDest    'Copio Datos, si les hubiera
     CopyRelationships dbsSRC, dbsDest 'Copio las relaciones entre estas tablas, si las hubiera
     dbsDest.Close
     dbsSRC.Close
     Exit Sub
errExists:
     If Err = 3204 Then
          MsgBox "No se ha podido concluir el proceso."
     Else
          MsgBox "Error: " & Error$, vbCritical + vbOKOnly, "AVISO DE ERROR"
     End If
     Exit Sub
End Sub


Sub CopyData(dbsSRC As Database, dbsDest As Database)
    Dim tbfSrc As TableDef, rstDest As Recordset, rstSrc As Recordset
    Dim wspTransact As Workspace
    Dim fldSrc As Field
   
    Set wspTransact = DBEngine.Workspaces(0)
    wspTransact.BeginTrans
    On Error GoTo errRollback
    For Each tbfSrc In dbsSRC.TableDefs
      If (tbfSrc.Attributes And dbSystemObject) Or _
        (tbfSrc.Connect <> "") Then
               ' Evito copiar Tablas del Sistema
        Else
            Set rstSrc = dbsSRC.OpenRecordset(tbfSrc.Name, dbOpenTable, _
                dbForwardOnly)
            If Not rstSrc.EOF Then
                Set rstDest = dbsDest.OpenRecordset(tbfSrc.Name, _
                    dbOpenDynaset, dbAppendOnly)
                Do While Not rstSrc.EOF
                     rstDest.AddNew
                     For Each fldSrc In rstSrc.Fields
                          rstDest(fldSrc.Name) = fldSrc.Value
                     Next
                         rstDest.Update
                         rstSrc.MoveNext
                    Loop
                    rstDest.Close
               End If
               rstSrc.Close
          End If
     Next
     wspTransact.CommitTrans
     Exit Sub
errRollback:
     MsgBox "Error:" & Error$
     wspTransact.Rollback
     Exit Sub

End Sub

Sub CopyFields(objSrc As Object, objDest As Object)
    Dim fldSrc As Field, fldDest As Field
    
    For Each fldSrc In objSrc.Fields
         If TypeName(objDest) = "TableDef" Then
              Set fldDest = objDest.CreateField(fldSrc.Name, fldSrc.Type, _
               fldSrc.Size)
         Else
              Set fldDest = objDest.CreateField(fldSrc.Name)
         End If
         CopyProperties fldSrc, fldDest
         objDest.Fields.Append fldDest
    Next
    Exit Sub

End Sub

Sub CopyQueries(dbSrc As Database, dbDest As Database)
    
     Dim qrySrc As QueryDef, qryDest As QueryDef
     For Each qrySrc In dbSrc.QueryDefs
          Set qryDest = dbDest.CreateQueryDef(qrySrc.Name, qrySrc.Sql)
          CopyProperties qrySrc, qryDest
     Next

End Sub


Sub CopyRelationships(dbsSRC As Database, dbsDest As Database)
     
     Dim relSrc As Relation, relDest As Relation
     For Each relSrc In dbsSRC.Relations
     Set relDest = dbsDest.CreateRelation("C" & relSrc.Name, _
        relSrc.Table, relSrc.ForeignTable, relSrc.Attributes)
          CopyFields relSrc, relDest
          dbsDest.Relations.Append relDest
     Next

End Sub
Sub CopyTables(dbsSRC As Database, dbsDest As Database)
    ' Esta rutina ya hace efectiva la incorporacion de las nuevas
    ' Tablas que acompañan a esta actualizacion, hacia el módulo
    ' de servicio.
    Dim tbfSrc As TableDef, tbfDest As TableDef
    Dim IntBuscar As String
    On Error GoTo ControlERROR
    For Each tbfSrc In dbsSRC.TableDefs
         If (tbfSrc.Attributes And dbSystemObject) Then
         Else
            Set tbfDest = dbsDest.CreateTableDef(tbfSrc.Name, _
                tbfSrc.Attributes, tbfSrc.SourceTableName, tbfSrc.Connect)
            If tbfSrc.Connect = "" Then
                CopyFields tbfSrc, tbfDest
                CopyIndexes tbfSrc.Indexes, tbfDest
            End If
            CopyProperties tbfSrc, tbfDest
            NumerodeTablas = NumerodeTablas + 1
            dbsDest.TableDefs.Append tbfDest
         End If
        
    Next
    On Error GoTo 0
    Exit Sub
ControlERROR:
    MsgBox "La Tabla: " & UCase(tbfSrc.Name) & " ya existe en su Base de Datos." & Chr(13) & _
    "Se cancela su copia y se continua con el proceso...", vbInformation + vbOKOnly, "PULSE ACEPTAR PARA CONTINUAR TRABAJANDO"
    NumerodeTablas = NumerodeTablas - 1
    Resume Next
    
End Sub

Sub CopyIndexes(idxsSrc As Indexes, objDest As Object)
 
     Dim idxSrc As Index, idxDest As Index, propSrc As Property
     For Each idxSrc In idxsSrc
          Set idxDest = objDest.CreateIndex(idxSrc.Name)
          CopyProperties idxSrc, idxDest
          CopyFields idxSrc, idxDest
          objDest.Indexes.Append idxDest
     Next

End Sub

Sub CopyProperties(objSrc As Object, objDest As Object)
     Dim prpProp As Property, temp As Variant
     On Error GoTo errCopyProperties
     For Each prpProp In objSrc.Properties
          objDest.Properties(prpProp.Name) = prpProp.Value
     Next
     On Error GoTo 0
     Exit Sub
errCopyProperties:
     Resume Next

End Sub

    Source: geocities.com/es/ensolva/Descargas/Documentos

               ( geocities.com/es/ensolva/Descargas)                   ( geocities.com/es/ensolva)                   ( geocities.com/es)