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