************************************
*Recopilado por el Buho de la Web:
*http://www.terra.es/personal2/sfortiz/
************************************
Crear Base datos Access
=======================
Function CreaBD_ACCESS(NombreBD as String) As Boolean
Dim cat As New ADOX.Catalog
On Error GoTo ErrorCreaBD_ACCESS
CreaBD_ACCESS = False
if Trim$(NombreBD)<>"" then
'Para conectar con BD Access 2000 usar el proveedor Microsoft.Jet.OLEDB.4.0.
'Para conectar con Access 97 usar Microsoft.Jet.OLEDB.3.51
cat.Create ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & NombreDB & ".MDB")
end if
CreaBD_ACCESS = True
Exit Function
ErrorCreaBD_ACCESS:
MuestraError "CreaBD_ACCESS", Err, Error
End Function
Establece Catalogo
==================
Function EstableceCatalogo(Conexion As ADODB.Connection,Cat as Adox.Catalog) As Boolean
On Error GoTo errorEstableceCatalogo
EstableceCatalogo= False
Set Cat= New ADOX.Catalog
Set Cat.ActiveConnection = Conexion
EstableceCatalogo= True
Exit Function
errorEstableceCatalogo:
MuestraError "EstableceCatalogo", Err, Error
End Function
Existe Tabla
============
Function ExisteTabla(cat As ADOX.Catalog, NombreTabla As String, ByRef tdfActual As ADOX.Table) As Boolean
Dim tdfBucle As New ADOX.Table
On Error GoTo ErrorExisteTabla
ExisteTabla = False
For Each tdfBucle In cat.Tables
If tdfBucle.Name = NombreTabla Then
Set tdfActual = tdfBucle
ExisteTabla = True
Exit For
End If
Next tdfBucle
Exit Function
ErrorExisteTabla:
MuestraError "ExisteTabla", Err, Error
End Function
Existe Campo
============
Function ExisteCampo(cat As ADOX.Catalog, tdfActual As ADOX.Table, NombreCampo As String) As Boolean
Dim fldBucle As New ADOX.Column
On Error GoTo ErrorExisteCampo
ExisteCampo = False
For Each fldBucle In tdfActual.Columns
If fldBucle.Name = NombreCampo Then
ExisteCampo = True
Exit For
End If
Next fldBucle
Exit Function
ErrorExisteCampo:
MuestraError "ExisteCampo", Err, Error
End Function
Existe Relación
===============
Function ExisteRelacion(cat As ADOX.Catalog, NombreTabla As String, NombreCampo As String) As Boolean
'Esta funcion una relacion en la DB si la encuentra retorna TRUE
Dim RelacionBucle As New ADOX.Key
On Error GoTo ErrorExisteRelacion
ExisteRelacion = False
For Each RelacionBucle In cat.Tables.Item(NombreTabla).Keys
If RelacionBucle.Name = NombreCampo Then
ExisteRelacion = True
Exit For
End If
Next RelacionBucle
Exit Function
ErrorExisteRelacion:
MuestraError "ExisteRelacion", Err, Error
End Function
Establece Tabla
===============
Function EstableceTabla(cat As ADOX.Catalog, NombreTabla As String, NombreCampo As String) As Boolean
Dim tdfActual as New ADOX.Table
Dim NombreTabla as String
Dim Cat as New Adox.Catalog
On Error GoTo ErrorEstableceTabla
EstableceTabla=False
if EstableceCatalogo(Conexion ,Cat) Then
NombreTabla="NombreTabla"
If Not ExisteTabla(cat, NombreTabla, tdfActual) Then
tdfActual.Name = NombreTabla
EstableceTabla=True
End If
End If
Exit Function
ErrorEstableceTabla:
MuestraError "EstableceTabla", Err, Error
End Function
Crea Campo
==========
Function Crea_Campo(cat As ADOX.Catalog, tdfActual As ADOX.Table, NombreCampo As String, Tamaño As String, Nulo As String, TipoDato As String) As Boolean
Dim Col As New ADOX.Column
Dim Punto As Long
Dim Entero As Long
Dim Real As Long
On Error GoTo ErrorCrea_Campo
Crea_Campo = False
'PARENTCATALOG para tener acceso a una propiedad específica de un proveedor
Set Col.ParentCatalog = cat
'Nombre de la columna
Col.Name = NombreCampo
'Segun el tipo de dato creamos el campo
Select Case TipoDato
Case "Entero":
Select Case Acceso
Case "ACCESS"
If Col.Type <> adSmallInt Then Col.Type = adSmallInt
Col.DefinedSize = Val(Tamaño)
Case "SQL"
If Col.Type <> adSmallInt Then Col.Type = adSmallInt
Col.DefinedSize = Val(Tamaño)
End Select
Case "EnteroLargo":
Select Case Acceso
Case "ACCESS"
If Col.Type <> adInteger Then Col.Type = adInteger
Col.DefinedSize = Val(Tamaño)
Case "S QL"
If Col.Type <> adInteger Then Col.Type = adInteger
Col.DefinedSize = Val(Tamaño)
End Select
Case "Texto":
If Col.Type <> adWChar Then Col.Type = adWChar
Col.DefinedSize = Val(Tamaño)
Case "Memo":
Col.Type = adLongVarWChar
Case "Date":
Select Case Acceso
Case "ACCESS"
If Col.Type <> adDate Then Col.Type = adDate
Case "SQL"
If Col.Type <> adDBTimeStamp Then Col.Type = adDBTimeStamp
End Select
Case "Flotante":
Select Case Acceso
Case "ACCESS"
If Col.Type <> adDouble Then Col.Type = adDouble
Case "SQL"
Punto = InStr(1, Tamaño, ".")
Entero = Mid(Tamaño, 1, Punto - 1)
Real = Mid(Tamaño, Punto + 1, Len(Tamaño))
Col.Type = adNumeric
Col.NumericScale = CLng(Real)
Col.Precision = CLng(Entero)
Col.Properties("Default") = "0"
End Select
End Select
If Nulo = "NULL" Then
If Acceso = "ACCESS" Then
Col.Properties("Jet OLEDB:Allow Zero Length") = True
Else
Col.Properties("Nullable") = True
End If
Else
If Acceso = "ACCESS" Then
Col.Properties("Jet OLEDB:Allow Zero Length") = False
Else
Col.Properties("Nullable") = False
End If
End If
tdfActual.Columns.Append Col
Crea_Campo = True
Exit Function
ErrorCrea_Campo:
MuestraError, "Crea_Campo", Err, Error
End Function
Crea Tabla
==========
Function Crea_Tabla(Conexion As ADODB.Connection, NombreDB As String, NombreTabla As String) As Boolean
Dim cat As New ADOX.Catalog
Dim tdfActual As New ADOX.Table
On Error GoTo ErrorCrea_Tabla
Crea_Tabla = False
If Trim$(NombreTabla) <> "" Then
' Abre el catálogo.
Set cat.ActiveConnection = Conexion
'Vemos si existe la tabla, si existe en tdfActual tengo el enlace de la tabla si no lo tengo que cear
If Not ExisteTabla(cat, NombreTabla, tdfActual) Then
'Creo la tabla si no existe previamente
tdfActual.Name = NombreTabla
cat.Tables.Append tdfActual
End If
End If
Crea_Tabla = True
Exit Function
ErrorCrea_Tabla:
MuestraError, "Crea_Tabla", Err, Error
End Function
Compactar BD
============
Function Compactar(Origen As String, Destino As String) As Boolean
'Hay que introducir la referencia Microsoft Jet and Replication
Dim Jet As New JRO.JetEngine
Dim BDOrigen As String
Dim BDDestino As String
On Error GoTo ErrorCompactar
Compactar = False
'Para conectar con BD Access 2000 usar el proveedor Microsoft.Jet.OLEDB.4.0.
'Para conectar con Access 97 usar Microsoft.Jet.OLEDB.3.51
BDOrigen = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Origen
BDDestino = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Destino & " ;Jet OLEDB:Engine Type=5"
Jet.CompactDatabase BDOrigen, BDDestino
Compactar = True
Exit Function
ErrorCompactar:
MuestraError , "Compactar", Err, Error
End Function
(
geocities.com/es/ensolva/Descargas) (
geocities.com/es/ensolva) (
geocities.com/es)