************************************
*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