Home‎ > ‎

Crear y Recuperar tus Tablas o Datos de una BD Access Sencilla

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
 
SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ

Descargar
Descargue el Ejemplo  359 kb v. 1 29 may. 2009 13:34 Jefferson Jimenez
Comments