Aveces nos preguntamos como crear un (Respaldo, Back-Up, Copia de Seguridad, etc...) de una base de datos sencilla
No se trata solo de copiar y pegar un Fichero o Archivo .mdb o .accdb
Preguntaba alguien.....
1) Lo que realmente busco es extraer toda la data de mis tablas y crear un fichero aparte .mdb o .accdb
Tambien que en el proceso de la extraccion se lleve las Relaciones.........
2) Luego de haber realizado esta operacion me la grabe con la fecha del sistema para asi saber de que dia pertenece la data o informacion
3) Y claro esta poder recupear la data o tablas desde mi base de datos en uso.....
Ok. Para todo esto tenemos que crear un modulo que realize las opciones 1 y 2
El Codigo
Option Compare Database
Public Sub CopiarTabasRelaciones(strFile As String)
' Funcion para copiar solo las tablas de la base de datos
' y sus relaciones
' strFile - es el nombre que le vas a dar a la copia. En este caso yo la llamare copia
On Error GoTo E_Handle
Dim dbFE As Database, dbBE As Database
Dim tdf As TableDef
Dim rel As Relation
Dim fld As Field
Dim astr(1 To 100, 1 To 4) As String
Dim intLoop As Integer, intRelCount As Integer, intTableCount As Integer
Dim strTable As String
Set dbFE = CurrentDb
intLoop = 1
If Len(Dir(strFile)) = 0 Then
Set dbBE = DBEngine(0).CreateDatabase(strFile, dbLangGeneral)
Else
Set dbBE = DBEngine(0).OpenDatabase(strFile)
End If
For Each rel In dbFE.Relations
For Each fld In rel.Fields
astr(intLoop, 1) = rel.Table
astr(intLoop, 2) = rel.ForeignTable
astr(intLoop, 3) = fld.Name
astr(intLoop, 4) = fld.ForeignName
intLoop = intLoop + 1
Next fld
Next rel
intRelCount = dbFE.Relations.Count - 1
For intLoop = intRelCount To 0 Step -1
'dbFE.Relations.Delete dbFE.Relations(intLoop).Name
Next intLoop
intTableCount = dbFE.TableDefs.Count - 1
For intLoop = intTableCount To 0 Step -1
strTable = dbFE.TableDefs(intLoop).Name
If Left(strTable, 4) <> "MSys" And Left(strTable, 4) <> "USys" And Len(dbFE.TableDefs(intLoop).Connect) = 0 Then
DoCmd.TransferDatabase acExport, "Microsoft Access", strFile, acTable, strTable, strTable
End If
Next intLoop
For intLoop = 1 To intRelCount + 1
Set rel = dbBE.CreateRelation(astr(intLoop, 1) & astr(intLoop, 2), astr(intLoop, 1), astr(intLoop, 2))
rel.Fields.Append rel.CreateField(astr(intLoop, 3))
rel.Fields(astr(intLoop, 3)).ForeignName = astr(intLoop, 4)
dbBE.Relations.Append rel
Next intLoop
MsgBox "Proceso Concluido con exito" & vbCrLf & _
"La copia se ha grabado en " & vbCrLf & _
CurrentProject.path & "\(Copia del " _
& Format(Date, "dd-mm-yyyy") & ") " _
& CurrentProject.Name & vbCrLf & _
"Solo hemos copiado las Tablas y Sus Relaciones, y tomado" & vbCrLf & _
"La fecha del sistema, para asi saber el dia de respaldo" & vbCrLf & _
"Y Recuperar la que necesitemos.........................", vbInformation, "Grabado"
sExit:
On Error Resume Next
Set rel = Nothing
Set dbFE = Nothing
dbBE.Close
Set dbBE = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & "CopiarTabasRelaciones", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Y Despues otro modulo que me realize la Opcion 3
El Codigo
Option Compare Database
Option Explicit
'******************* Jefferson Jimenez **************************
'****************** Cabimas, Venezuela **************************
'************************* Mayo 2009 ****************************
'****************************************************************
'Primero Elimino las Relaciones de las Tablas Actuales, _
..... Habiendo eliminado las relaciones, elimino las tablas .......
Function DltTblAct()
Dim dbFE As Database, dbBE As Database
Dim tdf As TableDef
Dim rel As Relation
Dim fld As Field
Dim astr(1 To 100, 1 To 4) As String
Dim intLoop As Integer, intRelCount As Integer, intTableCount As Integer
Dim strTable As String
Set dbFE = CurrentDb
intLoop = 1
For Each rel In dbFE.Relations
For Each fld In rel.Fields
astr(intLoop, 1) = rel.Table
astr(intLoop, 2) = rel.ForeignTable
astr(intLoop, 3) = fld.Name
astr(intLoop, 4) = fld.ForeignName
intLoop = intLoop + 1
Next fld
Next rel
intRelCount = dbFE.Relations.Count - 1
For intLoop = intRelCount To 0 Step -1
dbFE.Relations.Delete dbFE.Relations(intLoop).Name
Next intLoop
intTableCount = dbFE.TableDefs.Count - 1
For intLoop = intTableCount To 0 Step -1
strTable = dbFE.TableDefs(intLoop).Name
If Left(strTable, 4) <> "MSys" And Left(strTable, 4) <> "USys" And Len(dbFE.TableDefs(intLoop).Connect) = 0 Then
DoCmd.DeleteObject acTable, strTable
End If
Next intLoop
End Function
'Ahora Copio de la Base de Datos BackUp a la Base _
de Datos Actual todas las Tablas _
que en ella estan... Incluso con sus Relaciones
Public Function ImportDb(strPath As String) As Boolean
On Error Resume Next
Dim db, cdb As Database
Dim td As TableDef
Dim strTDef, strDocName, strRName, _
strTName, strFTName, strFName, _
strFFName As String
Dim intConst As Integer
Dim rel As Relation
Dim nrel As Relation
Dim varAtt As Variant
Dim fld As Field
Set db = DBEngine.Workspaces(0).OpenDatabase(strPath, True)
For Each td In db.TableDefs
strTDef = td.Name
If Left(strTDef, 4) <> "MSys" Then
DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, _
strTDef, strTDef, False
End If
Next
Set cdb = CurrentDb
For Each rel In db.Relations
With rel
strRName = .Name
strTName = .Table
strFTName = .ForeignTable
varAtt = .Attributes
Set nrel = cdb.CreateRelation(strRName, strTName, strFTName, varAtt)
For Each fld In .Fields
strFName = fld.Name
strFFName = fld.ForeignName
nrel.Fields.Append nrel.CreateField(strFName)
nrel.Fields(strFName).ForeignName = strFFName
Next
cdb.Relations.Append nrel
End With
Next
MsgBox "Concluido Exitosamente", vbInformation, "Gracias"
Set fld = Nothing
Set nrel = Nothing
Set rel = Nothing
Set cdb = Nothing
Set td = Nothing
db.Close
Set db = Nothing
ImportDb = True
End Function