'Proposito.
'Yo tengo una MDb situada en C:\TwPAc\Datos.mdb
'y deseo incorporar nuevas tablas a dicha MDB. ¿Como  lo hago?
'Creo una MDB (Esta donde corre este codigo) e incorporo en esta
'Mdb todas las tablas, datos, relaciones, indices etc que deseo
'Volcar en C:\TwPAc\Datos.mdb
'Esto viene muy bien como modelo de 'actualizacion' de programas.
'Yo tengo un programa que utiliza X tablas y deseo incorporar tablas
'nuevas necesarias para que corra la nueva version del programa.
'Este codigo esta probado y funcionando de forma real en mis
'aplicaciones de ACTUALIZACION de determinados programas.
'BHUO AGOSTO DE 2002




'La llamada a estas funciones se realizan desde un boton de
'comando de un formulario residente en esta base de datos, o sea, la
'misma donde se jecuta este codigo:
'Desde un formulario:
 Dim Origen As String
 Dim Destino As String
 Dim DondeEstamos As CurrentProject
 NumerodeTablas = 0
 MsgBox "Este puede ser un proceso largo.", vbExclamation + vbOKOnly, "COMENZAR"
  Set DondeEstamos = Application.CurrentProject
  Origen = DondeEstamos.FullName
  ' Esto que hemos hecho en las tres líneas anteriores es para
  ' averiguar donde está la ruta de esta MDB/MDE de actualización
  ' pues el usuario la ha podido depositar donde quiera
  Destino = "C:\TWPAC\DATOS.MDB"
  'La anterior linea es la mDB donde queremos copiar las tablas
  'incoporadas a esta MDB
  DoCmd.Hourglass True
  CopiaTablas Origen, Destino
  DoCmd.Hourglass False
  MsgBox "Proceso de incorporación de nuevas Tablas Concluido." & Chr(13) & _
  "Se han incorporado " & NumerodeTablas & " Tablas nuevas a su base de datos", vbInformation + vbOKOnly, "Fin del Proceso."
 
Option Compare Database
Option Explicit
'***************************************************************
'        (C) Francisco García Aguado, Junio de 2002            *
'                        Utiliza DAO                           *
'Este módulo es exclusivo para COPIAR TABLAS NUEVAS CON DATOS  *
'en el módulo de Servicio.                                     *
'Las nuevas tablas deberán  estar  grabadas  en esta MDB / MDE *
'de actualización                                              *
'***************************************************************


Sub CopiaTablas(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

'************************************************************************************
'************************************************************************************
'En este proceso lo que hemos hecho ha sido copiar las TABLAS
'que acompañan a esta base de Actualización, en el módulo de servicio
'que en el caso del ejemplo es C:\TWPAC\DATOS.MDB
'
'************************************************************************************
'************************************************************************************
Function Errores(NumeroError As Double, Formulario As String)
  ' ..............
 If NumeroError = 2105 Then
  MsgBox "Aviso desde el formulario:" & Formulario & Chr(13) _
       & "Nº: " & NumeroError & " ->" & "Se ha llegado al Principio / Fin del fichero de Datos", vbInformation + vbOKOnly, "PROGRAMA TALLER MECÁNICO 2000"
 Else
  MsgBox "Aviso desde el formulario:" & Formulario & Chr(13) _
       & "Nº: " & NumeroError & " ->" & Err.Description, vbInformation + vbOKOnly, "PROGRAMA TALLER MECÁNICO 2000"
    
 End If
 
End Function