Crear Back-End Usando Codigo VBA

Sencillo Ejemplo de como crear una Back-End o Base de Datos Vinculada Usando Codigo VBA

El Codigo

Option Compare Database

' Procedimiento para exportar todas las tablas de la parte delantera de un back-end

' Este código de exportar las relaciones del front-end y recrearlas en la base de datos

' back-end.

' Tiene un límite de 100 relaciones, pero esto puede ser cambiado manualmente

' modificando el límite superior de "astr" según sea necesario.

' """""""""""""Modificado por Jefferson Jimenez""""""""""""""""

Public Sub CrearBackEnd(Ruta As String)

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(Ruta)) = 0 Then

Set dbBE = DBEngine(0).CreateDatabase(Ruta, dbLangGeneral)

Else

Set dbBE = DBEngine(0).OpenDatabase(Ruta)

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", _

Ruta, acTable, strTable, strTable

DoCmd.DeleteObject acTable, strTable

DoCmd.TransferDatabase acLink, "Microsoft Access", _

Ruta, 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

sExit:

On Error Resume Next

Set rel = Nothing

Set dbFE = Nothing

dbBE.Close

Set dbBE = Nothing

Exit Sub

E_Handle:

MsgBox Err.Description & vbCrLf & "CrearBackEnd", vbOKOnly + vbCritical, _

"Error: " & Err.Number

Resume sExit

End Sub