Administrar relaciones mediante código o macro

[Taribo007]

Mira esto:
'*************************************************
'Sacado de la Ayuda de Access
'En una MDB con tablas ya existentes, como crear
'Relaciones entre las Tablas ya existentes de Datos.Mdb

Option Compare Database
Option Explicit

Function CreateRelationX()

Dim dbsNeptuno As Database
Dim tdfEmpleados As TableDef
Dim tdfNuevo As TableDef
Dim idxNuevo As Index
Dim relNuevo As Relation
Dim idxBucle As Index

Set dbsNeptuno = OpenDatabase("c:\Carpeta\Neptuno.mdb")

With dbsNeptuno
' Agrega un campo nuevo a la tabla Empleados.
Set tdfEmpleados = .TableDefs!Empleados
tdfEmpleados.Fields.Append _
tdfEmpleados.CreateField("IdDpto", dbInteger, 2)

' Crea la tabla Departmentos nueva.
Set tdfNuevo = .CreateTableDef("Departmentos")

With tdfNuevo
' Crea y agrega los objetos Field a la
' colección Fields del objeto TableDef nuevo.
.Fields.Append .CreateField("IdDpto", dbInteger, 2)
.Fields.Append .CreateField("NombreDpto", dbText, 20)

' Crea el objeto Index en la tabla Departamentos.
Set idxNuevo = .CreateIndex("ÍndiceIdDpto")
' Crea y agrega el objeto Field a la
' colección Fields del objeto Index nuevo.
idxNuevo.Fields.Append idxNuevo.CreateField("IdDpto")
' El índice en la tabla principal debe ser
' Unique para formar parte de un Relation.
idxNuevo.Unique = True
.Indexes.Append idxNuevo
End With

.TableDefs.Append tdfNuevo

' Crea el objeto Relation EmpleadosDepartamentos, utilizando los nombres
' de las dos tablas en la relación.
Set relNuevo = .CreateRelation("EmpleadosDepartamentos", _
tdfNuevo.Name, tdfEmpleados.Name, _
dbRelationUpdateCascade)

' Crea el objeto Field para la colección Fields
' del objeto Relation nuevo. Establece las
' propiedades Name y ForeignName basadas en los
' campos que se van a utilizar en la relación.
relNuevo.Fields.Append relNuevo.CreateField("IdDpto")
relNuevo.Fields!IdDpto.ForeignName = "IdDpto"
.Relations.Append relNuevo

' Imprime un informe.
Debug.Print "Properties de" & relNuevo.Name & _
" Relation"
Debug.Print " Tabla = " & relNuevo.Table
Debug.Print " TablaExterna = " & _
relNuevo.ForeignTable
Debug.Print "Fields de " & relNuevo.Name & " Relation"

With relNuevo.Fields!IdDpto
Debug.Print " " & .Name
Debug.Print " Nombre = " & .Name
Debug.Print " TablaExterna = " & .ForeignName
End With

Debug.Print "Indexes en " & tdfEmpleados.Name & _
" TableDef"
For Each idxBucle In tdfEmpleados.Indexes
Debug.Print " " & idxBucle.Name & _
", Foreign = " & idxBucle.Foreign
Next idxBucle

' Elimina los objetos nuevos porque estos es un ejemplo.
.Relations.Delete relNuevo.Name
.TableDefs.Delete tdfNuevo.Name
tdfEmpleados.Fields.Delete "IdDpto"
.Close
End With

End Function
'************************************************* *********

Y otra forma:
'************************************************* *********
Para crear una relación, tendrás que declarar una variable
objeto «DAO.Relation».

El siguiente ejemplo creará una relación de «uno a varios» entre las tablas
«Clientes» y «Facturas» mediante el campo «IdCliente», común en ambas tablas
de nuestra base de datos. Asimismo, se exigirá la integridad referencial y
se actualizará en cascada los campos relacionados:

Dim db As Database
Dim rel As DAO.Relation

' Abrimos la base de datos
Set db = OpenDatabase("C:\Bd1.mdb")

' Creamos una relación
Set rel = db.CreateRelation("ClientesFacturas", _
"Clientes", "Facturas", _
dbRelationUpdateCascade)

' Creamos el objeto «Field» del objeto «Relation»
rel.Fields.Append rel.CreateField("IdCliente")

' Indicamos el nombre del campo de la tabla externa
rel.Fields!IdCliente.ForeignName = "IdCliente"

' Añadimos la relación a la colección
db.Relations.Append rel

Para más información, consulta en la ayuda de DAO el método
«CreateRelation».
'************************************************* *********
Y otra mas:
'************************************************* *********
Option Compare Database
Option Explicit

Function CreaunatablaDAO()
Dim db As Database
Dim ObjetoTabla As TableDef

Set db = CurrentDb
Set ObjetoTabla = db.CreateTableDef("Mitabla")

With ObjetoTabla
.Fields.Append .CreateField("Campo1", dbText, 2)
.Fields.Append .CreateField("Campo2", dbInteger)
.Fields.Append .CreateField("Campo3", dbDate)
End With

db.TableDefs.Append ObjetoTabla
End Function

Function CreaTablaDDL()
Dim StrSql As String

StrSql = "CREATE TABLE Mitabla " _
& "(Id COUNTER PRIMARY KEY," _
& "[Campo1] TEXT(35) NOT NULL, " _
& "[Campo2] TEXT(50) NOT NULL, " _
& "Campo3 TEXT(200), " _
& "Email TEXT(50))"

CurrentDb.Execute StrSql
End Function

Function HacemosCambiosEnTabla()
'Permitir longitud cero
CurrentDb.TableDefs("Mitabla"). _
Fields("campo1"). _
Properties("AllowZeroLength") = True
'Cambiamos valor predeterminado
CurrentDb.TableDefs("Mitabla"). _
Fields("campo1"). _
Properties("DefaultValue") = """Valor que yo quiera"""


End Function

Sub crearTablasyRelacion()
'Esta se la pillé Juan M Afan de Ribera
'Creamos dos tablas y ademas creamos relacion entre ellas.
Dim cadSQL As String

'creamos una tabla de facturas
cadSQL = "CREATE TABLE Facturas " _
& "(IdFactura INTEGER PRIMARY KEY, " _
& "FechaFra DATETIME, " _
& "IdCliente INTEGER)"

'aquí utilizamos DAO
CurrentDb.Execute cadSQL

'creamos una tabla de detalle de facturas y relacionamos
'con la tabla facturas a través del campo IdFactura
cadSQL = "CREATE TABLE DetalleFacturas " _
& "(IdDetalle COUNTER PRIMARY KEY, " _
& "IdFactura INTEGER, " _
& "Cantidad INTEGER, " _
& "Descripcion TEXT(255), " _
& "PrecioUnitario DOUBLE, " _
& "CONSTRAINT ClaveExtFacturas FOREIGN KEY (IdFactura) " _
& "REFERENCES Facturas ON UPDATE CASCADE ON DELETE CASCADE)"

'aquí utilizamos ADO
CurrentProject.Connection.Execute cadSQL

End Sub

'********************************************
'Esta creo que es de Martí (Marjan) para borrar una tabla
Public Sub BorraTaula(NomTaula As String)
'Procedimiento para borrar tablas DAO 3.51
Dim mdb As Database
Set mdb = CurrentDb
Dim Taula As TableDef
For Each Taula In mdb.TableDefs
If Taula.Name = NomTaula Then
mdb.TableDefs.Delete (NomTaula): Exit For
End If
Next
mdb.Close
Set mdb = Nothing
End Sub
'*********************************************

Un saludo