'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
(
geocities.com/es/ensolva/Descargas) (
geocities.com/es/ensolva) (
geocities.com/es)