--------------------------------------------------------------------------------
Eduardo Olaz (Año 2002) posteado News de Access de Microsoft

Este código hace lo siguiente
 
Utilizando Sólo DAO
 
CrearBD Crea la base de datos
 DatosAmigos.mdb
 
CrearTablas 
    Crea 2 tablas, en esa base de datos, definiendo diferentes tipos de datos e índices.
         Amigos
         Sexos
    Establece una relación de integridad referencial con borrado en cascada en el campo idSexo entre
         Sexos
            y
         Amigos
 
AñadirDatos
    Añade datos a las dos tablas
 
MostrarAmigosDeMadrid
    Abre un recordset con algunos de los campos de las tablas, seleccionando los amigos de Madrid, y los muestra en la ventana de depuración.
 
Y ahora paciencia para digerir el código, que me ha salido un pelín largo.
¡Que aproveche!

--------------------------------------------------------------------------------

 
Option Explicit

' eduardo@olaz.net
' Junio de 2002
 
Const constrBD As String = "DatosAmigos.mdb"
Const conblnExclusivo As Boolean = True
Public Const conComilla As String = """"

Type TAmigo
    Nombre As String * 25
    Apellido As String * 25
    Sexo As String * 15
    FechaNacimiento As Date
    LugarNacimiento As String * 25
    Telefono As String * 25
    Nota As String
End Type

Public Sub CrearBDEnCarpetaActual( _
    Optional ByVal BaseDatos As String = constrBD)
    Dim strRuta As String
    
    strRuta = CurrentProject.Path & "\"
    'Llamamos al procedimiento para crear la BD
    CrearBD strRuta, BaseDatos
End Sub

Public Sub CrearBD( _
            ByVal Ruta As String, _
            ByVal FicheroBD As String)
            
    Dim wrkActual As DAO.Workspace
    Dim dbNuevo As DAO.Database
    Dim strFicheroBD As String
    Dim lngRespuesta As Long
    
    If Right(Ruta, 1) <> "\" Then
        Ruta = Ruta & "\"
    End If
    strFicheroBD = Ruta & FicheroBD
    'Comprobamos si existe la BD a crear
    If Dir(strFicheroBD) = FicheroBD Then
        lngRespuesta = MsgBox(" ¿Desea borrar la base de datos" & vbCrLf _
                        & strFicheroBD & "?", _
                        vbYesNo + vbInformation, _
                        " La base de datos " & FicheroBD & " ya existe")
        'Si la respuesta es sí borramos la BD anterior
        If lngRespuesta = vbYes Then
            Kill strFicheroBD
        Else
            Exit Sub
        End If
    End If
    'Asignamos a wrkActual la sesión actual
    Set wrkActual = DBEngine.Workspaces(0)
    'Asignamos a dbNuevo la base de datos creada
    'con el sistema de ordenación Español moderno
    Set dbNuevo = CreateDatabase(strFicheroBD, dbLangGeneral)
    dbNuevo.Close
    Set dbNuevo = Nothing
    Set wrkActual = Nothing
End Sub

Public Sub CrearTablas()
    'Ojo, sin control de excepciones

    Dim dbDatos As DAO.Database
    Dim tdfTabla As DAO.TableDef
    Dim fldCampo As DAO.Field
    Dim idxIndice As DAO.Index
    Dim relRelacion As DAO.Relation
    Dim strNombreBD As String
    Dim strRuta As String
      
    strRuta = CurrentProject.Path
    strNombreBD = strRuta & "\" & constrBD
    
    ' Si no existe Datos.mdb lo creamos
    If Dir(strNombreBD) = "" Then
        CrearBD strRuta, constrBD
    End If
    'Asignamos la BD Datos.mdb a dbDatos, abriéndola en modo exclusivo
    'Mdiante la función DameBDAmigos
    Set dbDatos = DameBDAmigos(conblnExclusivo)
    
    '**************************************************
    'Creamos la tabla [Sexos]
    Set tdfTabla = dbDatos.CreateTableDef("Sexos")
    
    'Vamos añadiendo los campos a la tabla
    With tdfTabla
        'Le añadimos el campo [idSexo], Texto 1 carácter
        Set fldCampo = .CreateField("idSexo", dbText, 1)
        With fldCampo
            ' vamos a permitir sólo ciertos tipos de datos
            .ValidationRule = "=M or =F or =I or = H"
            .ValidationText = "Debe introducir M ó F ó I ó H " _
               & "(Masculino, Femenino, Indefinido, Hermafrodita)"
            .Required = True
            .AllowZeroLength = False
        End With
        .Fields.Append fldCampo
        'Le añadimos el campo [Sexo], Autoincremental
        Set fldCampo = .CreateField("Sexo", dbText, 15)
        fldCampo.Required = True
        fldCampo.AllowZeroLength = False
        .Fields.Append fldCampo
    End With
    
    'Añadimos la tabla a Tabledefs

    
    '--------------------------------------------------
    'Creamos los índices para la tabla Sexos
    With tdfTabla
        'Creamos el índice de [idSexo]
        Set idxIndice = .CreateIndex("idSexo")
        'Le decimos qué campo va a procesar
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("idSexo")
            'Definimos el campo como clave
            .Unique = True
            .Primary = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Sexo]
        Set idxIndice = .CreateIndex("Sexo")
        With idxIndice
            .Fields.Append .CreateField("Sexo")
            .Unique = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
    End With
    
    dbDatos.TableDefs.Append tdfTabla
        
    '**************************************************
    'Creamos la tabla [Amigos]
    Set tdfTabla = dbDatos.CreateTableDef("Amigos")
    
    'Vamos añadiendo los campos a la tabla
    With tdfTabla
        'Le añadimos el campo [idAmigo], Autoincremental
        Set fldCampo = .CreateField("idAmigo", dbLong)
        .Fields.Append fldCampo
        fldCampo.Attributes = dbAutoIncrField
        
        'También se puede crear un campo de forma directa
        'Creamos el campo [AmigoNombre]
        .Fields.Append .CreateField("AmigoNombre", dbText, 25)
        .Fields("AmigoNombre").Required = True
        
        'Creamos el campo [AmigoApellido]
        .Fields.Append .CreateField("AmigoApellido", dbText, 25)
        .Fields("AmigoApellido").Required = True
        
        'Le añadimos el campo [idSexo], texto, de 1 caracter
        .Fields.Append .CreateField("idSexo", dbText, 1)
        'Podemos volver a llamar a ese campo para definir propiedades
        Set fldCampo = .Fields("idSexo")
             With fldCampo
                .Required = True
                .AllowZeroLength = False
            End With
        
        'Creamos el campo [AmigoFechaNacimiento]
        .Fields.Append .CreateField("AmigoFechaNacimiento", dbDate)
        .Fields("AmigoFechaNacimiento").Required = False
        
        'Creamos el campo [AmigoLugarNacimiento]
        .Fields.Append .CreateField("AmigoLugarNacimiento", dbText, 25)
        .Fields("AmigoLugarNacimiento").Required = False
        
        'Creamos el campo [AmigoTelefono]
        .Fields.Append .CreateField("AmigoTelefono", dbText, 25)
        .Fields("AmigoTelefono").Required = False
        
        'Creamos el campo [Notas]
        .Fields.Append .CreateField("Notas", dbMemo)
        .Fields("Notas").Required = False
    End With
    
    'Añadimos la tabla a Tabledefs
    dbDatos.TableDefs.Append tdfTabla
    
    '--------------------------------------------------
    'Creación de índices
    '[idAmigo] llamado idAmigo
    'Otro para [idSexo] Llamado idSexo
    
    With tdfTabla
        'Creamos el índice de [idAmigo]
        Set idxIndice = .CreateIndex("idAmigo")
        'Le decimos qué campo va a procesar
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("idAmigo")
            'Definimos el campo como clave
            .Unique = True
            .Primary = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Sexo]
        Set idxIndice = .CreateIndex("Sexo")
        With idxIndice
            .Fields.Append .CreateField("idSexo")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        
        'Creamos el índice [Nombre]
        Set idxIndice = .CreateIndex("Nombre")
        With idxIndice
            ' Creamos el índice idAmigo
            .Fields.Append .CreateField("AmigoNombre")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        'Creamos el índice [Apellido]
        Set idxIndice = .CreateIndex("Apellido")
        With idxIndice
            ' Creamos el índice Apellido
            .Fields.Append .CreateField("AmigoApellido")
            .Required = True
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        Set idxIndice = .CreateIndex("FechaNacimiento")
        With idxIndice
        ' Creamos el índice FechaNacimiento
            .Fields.Append .CreateField("AmigoFechaNacimiento")
        End With
        'Añadimos el índice a la colección indexes de tdfTabla
        .Indexes.Append idxIndice
        'Creamos un índice compuesto del Nombre y Apellido
        'Indice ApellidoNombre
        Set idxIndice = .CreateIndex("ApellidoNombre")
        'Le decimos qué campos va a incluir
        With idxIndice
            .Fields.Append .CreateField("AmigoApellido")
            .Fields.Append .CreateField("AmigoNombre")
            'Definimos como clave única
            '(es un ejercicio
            ' y no voy a tener amigos repetidos
            ' en Nombre y Apellidos)
            .Unique = True
        End With
        .Indexes.Append idxIndice
    End With
    
    'Vamos ahora a relacionar la dos tablas
    'a través de su campo idSexo
    'las relaciones pertenecen a la Base de Datos
    With dbDatos
        'Creamos la relación con actualización en cascada
        '    (dbRelationUpdateCascade),
        'que muestre todos los datos de sexo
        'y los de la tabla amigos relacionados
        '    (dbRelationLeft)
        Set relRelacion = .CreateRelation("SexoAmigos", _
                "Sexos", "Amigos", _
                dbRelationUpdateCascade + dbRelationLeft)
                
        'Creamos los campos de la relación
        With relRelacion
            .Fields.Append .CreateField("IdSexo")
            .Fields!idSexo.ForeignName = "idSexo"
        End With
        .Relations.Append relRelacion
    End With
    
Set idxIndice = Nothing
Set fldCampo = Nothing
Set tdfTabla = Nothing
dbDatos.Close
Set dbDatos = Nothing

End Sub

Public Sub AñadirDatos()
    Dim strRuta As String
    Dim strBD As String
    Dim lngRespuesta As Long
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    strRuta = CurrentProject.Path & "\"
    strBD = strRuta & constrBD
    
    'Comprueba si existe la Base de datos
    If Dir(strBD) = constrBD Then
        lngRespuesta = MsgBox( _
                    "La base " & constrBD & " existe" _
                    & vbCrLf & _
                    "¿Desea borrarla?", _
                    vbInformation + vbYesNo, _
                    " Permiso para masacrar " & constrBD)
        If lngRespuesta = vbYes Then
            Kill strBD
        Else
            MsgBox "No se van a cambiar los datos", _
                    vbInformation + vbOKOnly, _
                    " Interrumpido procedimiento"
            Exit Sub
        End If
    End If

    'Crea la BD con tablas
    CrearTablas
    
    Set db = DameBDAmigos(conblnExclusivo)
    'Voy a abrir el recordset como dinámico
    Set rs = db.OpenRecordset("Sexos", dbOpenDynaset)
    
    With rs
        'Si no tiene datos los añadiremos
        If Not .RecordCount Then
            .AddNew
            'Añadimos un registro nuevo
            !idSexo = "M"
            !Sexo = "Masculino"
            'Una vez lleno lo actualizamos
            .Update
            
            .AddNew
            !idSexo = "F"
            !Sexo = "Femenino"
            .Update
            
            .AddNew
            !idSexo = "I"
            !Sexo = "Indefinido"
            .Update
            
            .AddNew
            !idSexo = "H"
            !Sexo = "Hermafrodita"
            .Update
            
        End If
    End With
    rs.Close
    'Voy a abrir el recordset como tabla
    Set rs = db.OpenRecordset("Amigos", dbOpenTable)
    With rs
        'Si no tiene datos los añadiremos
        If Not .RecordCount Then
            .AddNew
            !AmigoNombre = "Boris"
            !AmigoApellido = "Izaguirre"
            !AmigoFechaNacimiento = #9/29/1965#
            !AmigoLugarNacimiento = "Caracas"
            !AmigoTelefono = "91 111 111 111"
            !idSexo = "I"
            !Notas = "Obsesionado por bajarse los pantalones"
            .Update
            
            .AddNew
            !AmigoNombre = "Inés"
            !AmigoApellido = "Sastre"
            !AmigoFechaNacimiento = #11/21/1973#
            !AmigoLugarNacimiento = "Madrid"
            !AmigoTelefono = "91 222 222 222"
            !idSexo = "F"
            !Notas = "Le gusta montar a caballo, jugar golf y nadar"
            .Update
            
            .AddNew
            !AmigoNombre = "Michael Joseph"
            !AmigoApellido = "Jackson"
            !AmigoFechaNacimiento = #8/29/1958#
            !AmigoLugarNacimiento = "Gary - Indiana (USA)"
            !AmigoTelefono = "00 1 333 333 333 333"
            !idSexo = "H"
            !Notas = "A este chico últimamente se le está poniendo mala cara"
            .Update
            
            .AddNew
            !AmigoNombre = "Francisco"
            !AmigoApellido = "Ribera"
            !AmigoFechaNacimiento = #1/3/1974#
            !AmigoLugarNacimiento = "Madrid"
            !AmigoTelefono = "639 444 444"
            !idSexo = "M"
            !Notas = "Le gustan los cuernos"
            .Update
            
            .AddNew
            !AmigoNombre = "Aitana"
            !AmigoApellido = "Sánchez - Gijón"
            !AmigoFechaNacimiento = #9/5/1968#
            !AmigoLugarNacimiento = "Roma"
            !AmigoTelefono = "655 555 555"
            !idSexo = "F"
            !Notas = "Una gata sobre el tejado de zinc"
            .Update
            
        End If
    End With
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Public Sub MostrarAmigosDeMadrid()

    Dim strSQL As String
    Dim strBD As String
    Dim lngRegistro As Long

    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Dim Amigo As TAmigo
      
    Set db = DameBDAmigos()
    strSQL = "SELECT Sexo, " _
            & "[AmigoNombre] & " _
            & conComilla & " " & conComilla & "& " _
            & "[AmigoApellido] AS Amigo, " _
            & "Notas FROM Sexos LEFT JOIN Amigos " _
            & "ON Sexos.idSexo = Amigos.idSexo " _
            & "WHERE AmigoLugarNacimiento = " _
            & conComilla & "Madrid" & conComilla

    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    
    If rs.RecordCount Then
        Debug.Print Tab(1); "Sexo"; _
                Tab(16); "Amigo"; _
                Tab(45); "Notas"
                
        rs.MoveFirst
        Do While Not rs.EOF
            With rs
                Debug.Print Tab(1); !Sexo; _
                    Tab(16); !Amigo; _
                    Tab(45); !Notas
                .MoveNext
            End With
        Loop
    End If
     
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Public Function DameBDAmigos( _
            Optional ByVal Exclusivo As Boolean = False) _
            As DAO.Database
    Dim strRuta As String
    Dim strBD As String
    
    strRuta = CurrentProject.Path & "\"
    strBD = strRuta & constrBD
    
    'Si no existe la base de datos
    If Not Dir(strBD) = constrBD Then
        'La creamos
        CrearBD strRuta, constrBD
    End If
    Set DameBDAmigos = DBEngine.Workspaces(0).OpenDatabase( _
                        strBD, _
                        Exclusivo)
End Function


--------------------------------------------------------------------------------
'Supongo que a más de uno le vendrá bien, si es que no se le indigesta antes.
'Eduardo