Option Compare Database Option Explicit Dim strMensajeError As String Dim lngBotonesError As String Dim strTituloError As String '______________________________ Public Sub CrearBaseDeDatos() Dim strBaseDatos As String Dim strTabla As String Dim strCampo As String Dim strIndice As String 'Creamos el fichero Access strBaseDatos = "c:\Prueba.mdb" CrearFicheroMDB strBaseDatos 'Para Crear una tabla llamada "Datos" strTabla = "Datos" strCampo = "idDato" 'Para crear una tabla debe tener al menos un campo CrearCampo strTabla, _ strCampo, _ dbLong, _ strBaseDatos, _ Requerido:=True 'Este campo tendrá un índice 'llamado "idDato" que será Primario strIndice = "idDato" CrearIndice strIndice, _ strCampo, _ strTabla, _ strBaseDatos, _ Primario:=True, _ Unico:=True 'Añadimos a la tabla el campo "DatoTexto" ' será requerido y tendrá 50 caracteres strCampo = "DatoTexto" CrearCampo strTabla, _ strCampo, _ dbText, _ strBaseDatos, _ Requerido:=True, _ TamañoTexto:=50 'Este campo estará indexado y será sin duplicados strIndice = "DatoTexto" CrearIndice strIndice, _ strCampo, _ strTabla, _ strBaseDatos, _ Unico:=True 'Añadimos otro campo de tipo Long 'también requerido strCampo = "DatoLong" CrearCampo strTabla, _ strCampo, _ dbLong, _ strBaseDatos, _ Requerido:=True 'Añadimos otro campo de tipo Currency strCampo = "DatoMoneda" CrearCampo strTabla, _ strCampo, _ dbCurrency, _ strBaseDatos 'Creamos una segunda tabla llamada "Grupos" strTabla = "Grupos" strCampo = "idGrupo" 'Para crear una tabla debe tener al menos un campo CrearCampo strTabla, _ strCampo, _ dbLong, _ strBaseDatos, _ Requerido:=True 'Este campo tendrá un índice 'llamado "idDato" que será Primario y Único strIndice = "idGrupo" CrearIndice strIndice, _ strCampo, _ strTabla, _ strBaseDatos, _ Primario:=True, _ Unico:=True 'Añadimos a la tabla el campo "Grupo" de 20 caracteres strCampo = "Grupo" CrearCampo strTabla, _ strCampo, _ dbText, _ strBaseDatos, _ Requerido:=True, _ TamañoTexto:=20 'Este campo estará indexado y será sin duplicados strIndice = "Grupo" CrearIndice strIndice, _ strCampo, _ strTabla, _ strBaseDatos, _ Unico:=True 'Ahora añadimos el campo "idGrupo" a la 1ª tabla 'que relacionaremos con la anterior y será requerido strTabla = "Datos" strCampo = "idGrupo" CrearCampo strTabla, _ strCampo, _ dbLong, _ strBaseDatos, _ Requerido:=True 'Este campo tendrá el índice "idGrupo" strIndice = "idGrupo" CrearIndice strIndice, _ strCampo, _ strTabla, _ strBaseDatos 'Creamos la relación CrearRelacion "GruposDatos", _ "Grupos", _ "idGrupo", _ "Datos", _ strBaseDatos, _ ActualizarEnCascada:=True, _ IntegridadReferencial:=True End Sub '______________________________ Public Sub CrearFicheroMDB(ByVal RutaBD As String) On Error GoTo AvisoError ' Si existe la base de datos ' avisa generando el correspondiente error If Dir(RutaBD) <> "" Then Err.Raise 10001, , _ "Ya existe el fichero: " _ & vbCrLf & vbCrLf _ & RutaBD End If Dim WK As Workspace Dim DB As Database Set WK = Workspaces(0) Set DB = WK.CreateDatabase(RutaBD, _ dbLangGeneral) DB.Close Set DB = Nothing Set WK = Nothing Salir: Exit Sub AvisoError: lngBotonesError = vbCritical + vbOKOnly strTituloError = " Base de datos no válida" Select Case Err.Number Case 10001 strMensajeError = Err.Description Case Else strMensajeError = "Imposible crear la base de Datos: " & RutaBD _ & vbCrLf _ & " Se ha producido el error nº " _ & Err.Number _ & vbCrLf _ & Err.Description End Select MsgBox strMensajeError, lngBotonesError, strTituloError Resume Salir End Sub '______________________________ Public Sub CrearCampo(ByVal Tabla As String, _ ByVal Campo As String, _ ByVal Tipo As Long, _ BaseDatos As String, _ Optional ByVal Requerido As Boolean, _ Optional ByVal TamañoTexto As Long) Dim blnExistetabla As Boolean Dim dbf As Database Dim tdf As TableDef Set dbf = Workspaces(0).OpenDatabase(BaseDatos) For Each tdf In dbf.TableDefs If tdf.Name = Tabla Then blnExistetabla = True Exit For End If Next If Not blnExistetabla Then Set tdf = dbf.CreateTableDef(Tabla) Else Set tdf = dbf.TableDefs(Tabla) End If With tdf Select Case Tipo Case dbText .Fields.Append .CreateField(Campo, dbText, TamañoTexto) Case Else .Fields.Append .CreateField(Campo, Tipo) End Select .Fields(Campo).Required = Requerido End With If Not blnExistetabla Then dbf.TableDefs.Append tdf End If Set tdf = Nothing Set dbf = Nothing End Sub '______________________________ Public Sub CrearIndice(ByVal Indice As String, _ ByVal Campo As String, _ ByVal Tabla As String, _ BaseDatos As String, _ Optional ByVal Primario As Boolean, _ Optional ByVal Unico As Boolean) Dim dbf As Database Dim tdf As TableDef Dim idx As Index Dim blnExisteIndice As Boolean Set dbf = Workspaces(0).OpenDatabase(BaseDatos) Set tdf = dbf.TableDefs(Tabla) For Each idx In tdf.Indexes If idx.Name = Indice Then blnExisteIndice = True Exit For End If Next If blnExisteIndice Then idx.Fields.Append tdf.CreateField(Campo) Else Set idx = tdf.CreateIndex(Indice) idx.Fields.Append tdf.CreateField(Campo) End If idx.Unique = Unico idx.Primary = Primario tdf.Indexes.Append idx Set idx = Nothing Set tdf = Nothing Set dbf = Nothing End Sub '______________________________ Public Sub CrearRelacion(ByVal Relacion As String, _ ByVal TablaPrincipal As String, _ ByVal CampoPrincipal As String, _ ByVal TablaRelacionada As String, _ BaseDatos As String, _ Optional ByVal RelacionUnica As Boolean, _ Optional ByVal IntegridadReferencial As Boolean, _ Optional ByVal ActualizarEnCascada As Boolean, _ Optional ByVal EliminarEnCascada As Boolean) 'Tal y como está definido el procedimiento, 'requiere que los campos de la tabla Principal y relacionada, se llamen igual Dim dbf As Database Dim tdfPrincipal As TableDef Dim tdfRelacionado As TableDef Dim rel As Relation Dim lngAtributos As Long 'Definimos el parámetro de los atributos de la relación lngAtributos = -(Not IntegridadReferencial) * dbRelationDontEnforce _ - IntegridadReferencial * dbRelationLeft lngAtributos = lngAtributos - RelacionUnica * dbRelationUnique lngAtributos = lngAtributos - ActualizarEnCascada * dbRelationUpdateCascade lngAtributos = lngAtributos - EliminarEnCascada * dbRelationDeleteCascade Set dbf = Workspaces(0).OpenDatabase(BaseDatos) Set tdfPrincipal = dbf.TableDefs(TablaPrincipal) Set tdfRelacionado = dbf.TableDefs(TablaPrincipal) Set rel = dbf.CreateRelation(Relacion, _ TablaPrincipal, _ TablaRelacionada, _ lngAtributos) rel.Fields.Append rel.CreateField(CampoPrincipal) rel.Fields(CampoPrincipal).ForeignName = CampoPrincipal dbf.Relations.Append rel Set tdfPrincipal = Nothing Set tdfRelacionado = Nothing Set dbf = Nothing End Sub