El código completo y una captura del formulario en tiempo de diseño, para Crear una base de datos, crear una tabla y compactar la base de datos, usando ADO.
Este link es para bajarte el código completo: ejemplo29sep2001.zip 3.76 KB
El formulario en tiempo de diseño:
El código:
'------------------------------------------------------------------------------
' Ejemplo de crear Bases de datos y tablas con ADOX (28/Sep/01)
'
' ©Guillermo 'guille' Som, 2001
'
' Las referencias usadas son:
' Microsoft ADO Ext. 2.6 for DDL and Security
' Microsoft Jet and Replication Objects 2.6 Library
'
' Para más información:
' Fuente: Microsoft Data Access Components (MDAC) SDK
' MDAC Technical Articles (MSDN Library)
' Artículo: Defining and Retrieving a Database’s Schema
' Artículo: Miscellaneous / Compacting a Database
'------------------------------------------------------------------------------
Option Explicit
Private Sub cmdCrearBase_Click()
' Crear una base de datos usando los datoos indicados en: (28/Sep/01)
' txtNombreBase El nombre (y path) de la base de datos
' cboProvider El proveedor de la base de datos
'
Dim cat As ADOX.Catalog
'
' Si se produce un error: interceptarlo
On Error GoTo ErrCrearBase
'
Set cat = New ADOX.Catalog
'
' Si existe la base de datos, preguntar si queremos borrarla
If Len(Dir$(txtNombreBase.Text)) Then
If MsgBox("La base de datos ya existe." & vbCrLf & _
"¿Quieres Borrarla?", _
vbQuestion + vbYesNo + vbDefaultButton2 _
) = vbNo Then
Exit Sub
Else
Kill txtNombreBase.Text
End If
End If
'
' Crear la base de datos
cat.Create "Provider=" & cboProvider.Text & ";" & _
"Data Source=" & txtNombreBase.Text & ";"
'
MsgBox "Base de datos creada satisfactoriamente."
'
' Para no "colarnos" en la rutina de error
Exit Sub
'
ErrCrearBase:
' Mostrar el mensaje de error
MsgBox "Error al crear la base de datos:" & vbCrLf & _
Err.Number & " " & Err.Description, _
vbExclamation, "Error al crear la base de datos"
Err.Clear
End Sub
Private Sub cmdCrearTabla_Click()
' Crear una tabla en la base de datos indicada (28/Sep/01)
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
'
On Error GoTo ErrCrearTabla
'
Set cat = New ADOX.Catalog
Set tbl = New ADOX.Table
'
' Abrir el catálogo
cat.ActiveConnection = _
"Provider=" & cboProvider.Text & ";" & _
"Data Source=" & txtNombreBase.Text & ";"
'
' Crear la nueva tabla
With tbl
.Name = txtNombreTabla.Text
' Crear los campos y añadirlos a la tabla.
' Esto hay que hacerlo antes de añadir la tabla a la colección de tablas
'
.Columns.Append "ID", adInteger
' Dependiendo del tipo de proveedor, los datos de cadena serán de un tipo u otro
If cboProvider.Text = "Microsoft.Jet.OLEDB.3.51" Then
' Para Access 97
.Columns.Append "Nombre", adVarChar, 50 ' Una cadena de 50 caracteres
.Columns.Append "email", adVarChar, 100
.Columns.Append "Telefono", adVarChar
.Columns.Append "Observaciones", adLongVarChar ' Una cadena larga, (Memo)
Else
' Para Access 2000
.Columns.Append "Nombre", adVarWChar, 50 ' Una cadena de 50 caracteres
.Columns.Append "email", adVarWChar, 100
.Columns.Append "Telefono", adVarWChar
.Columns.Append "Observaciones", adLongVarWChar ' Una cadena larga, (Memo)
End If
.Columns("Nombre").Attributes = adColNullable ' Permite contener nulos
.Columns("email").Attributes = adColNullable
.Columns("Telefono").Attributes = adColNullable
.Columns("Observaciones").Attributes = adColNullable
End With
'
' Añadir la nueva tabla a la base de datos
cat.Tables.Append tbl
'
SalirCrearTabla:
Set tbl = Nothing
Set cat = Nothing
'
Exit Sub
'
ErrCrearTabla:
' Mostrar el mensaje de error
MsgBox "Error al crear la tabla:" & vbCrLf & _
Err.Number & " " & Err.Description, _
vbExclamation, "Error al crear la tabla"
Err.Clear
Resume SalirCrearTabla
End Sub
Private Sub cmdCompactar_Click()
' Compactar una base de datos con ADO
Dim sDBTmp As String
Dim je As JRO.JetEngine
'
On Error GoTo ErrCompactar
'
Set je = New JRO.JetEngine
'
' Crear un nombre "medio" aleatorio
sDBTmp = "DBT_" & Format$(Minute(Now), "00") & Format$(Second(Now), "00") & ".mdb"
' Asegurarnos de que no existe una base con el nombre temporal
If Len(Dir$(sDBTmp)) Then
Kill sDBTmp
End If
'
lblInfo.Caption = " Compactando la base de datos..."
lblInfo.Refresh
'
' Compactar la base de datos
je.CompactDatabase "Data Source=" & txtNombreBase.Text & ";", _
"Data Source=" & sDBTmp & ";"
'
' Eliminar la base de datos original
Kill txtNombreBase.Text
'
' Renombrar la base temporal con el original
Name sDBTmp As txtNombreBase.Text
'
lblInfo.Caption = " Base de datos compactada."
lblInfo.Refresh
'
Exit Sub
'
ErrCompactar:
' Mostrar el mensaje de error
MsgBox "Error al compactar la base de datos:" & vbCrLf & _
Err.Number & " " & Err.Description, _
vbExclamation, "Error al compactar la base de datos"
Err.Clear
lblInfo.Caption = " *** Error al compactar la base de datos ***"
lblInfo.Refresh
End Sub
Private Sub Form_Load()
With Me.cboProvider
.AddItem "Microsoft.Jet.OLEDB.4.0" ' (Access 2000)
.AddItem "Microsoft.Jet.OLEDB.3.51" ' (Access 97)
.ListIndex = 0
End With
txtNombreBase.Text = "PruebaADO.mdb"
txtNombreTabla.Text = "Tabla1"
lblInfo.Caption = "©Guillermo 'guille' Som, 2001" & IIf(Year(Now) > 2001, "-" & CStr(Year(Now)), "")
End Sub
