Bases de datosAPI'S PARA LAS BASES DE DATOS
(43 Rutinas disponibles)
Abrir una base de datos con seguridad en ADO
A través de este ejemplo mostraremos como abrir mediante ADO una base de datos 
de Access protegida con contraseña.
Dim Cn As New ADODB.Connection
Dim strCn As String
strCn = "Provider=Microsoft.Jet.OLEDB.3.51;" & _
"Data Source=nwind.MDB;" & _
"Jet OLEDB:System database=c:\winnt\system32\System.MDW"
Cn.Open ConnectionString:=strCn, _
UserID:="Admin", Password:="ambsoftware"
Acceso con y sin claves a todas las bases de datos
A continuación se muestran varias rutinas todas ellas encaminadas a acceder a 
todas las bases de datos, estén o no protegidas con contraseña.
Abrir una Tabla de Fox o dBase o... desde código 
Menu Proyecto->Referencias Seleccionar DAO 3.51 

Dim dbs As DAO.Database 
Dim rs As DAO.Recordset 

Set dbs = OpenDatabase("C:\Via\", True, False, "FoxPro 2.5") 
Set rs = dbs.OpenRecordset("Libros") 

Abrir Base de Datos de Access 97 Sin PassWord para asociarla con un Control Data 

Insertar un Control DATA 

Desde Código 

Data1.DatabaseName = "c:\Via\ACCESS97.MDB" 
Data1.RecordSource = "Tabla" 
Data1.Refresh 

ó 

En la Ventana de Propiedades del Objeto 

DatabaseName = "c:\Via\ACCESS97.MDB" 
RecordSource = "Tabla" 

Abrir Base de Datos de Access 97 con PassWord para asociarla con un Control Data 

Insertar un Control DATA 

Desde Código 

Dim cPass as String 
Dim Clave as String 
Clave = "Password" 
cPass = ";PWD=" & Clave 

Data1.DatabaseName = "c:\Via\ACCESS97.MDB" 

Data1.RecordSource = "Tabla" 

Data1.Connect = cPass 

Data1.Refresh 

Abrir Base de Datos de Access 97 SIN PassWord desde Código y Sin Data Control 
Menu Proyecto->Referencias Seleccionar DAO 3.51 

Dim dbs As DAO.Database 
Dim rs As DAO.Recordset 

Set dbs = OpenDatabase("C:\Via\ACCESS97.MDB", True, False,) 
Set rs = dbs.OpenRecordset("Tabla") 

Abrir Base de Datos de Access 97 CON PassWord desde Código y Sin Data Control 
Menu Proyecto->Referencias Seleccionar DAO 3.51 

Dim dbs As DAO.Database 
Dim rs As DAO.Recordset 
Dim cPass as String 
Dim Clave as String 

Clave = "Password" 
cPass = ";PWD=" & Clave 

Set dbs = OpenDatabase("C:\Via\ACCESS97.MDB", True, False, cPass) 'no se deben 
omitir el segundo ni el tercer parámetro para que entre el password 
Set rs = dbs.OpenRecordset("Tabla") 

Abrir Base de Datos de Access 2000 Sin PassWord para asociarla con un Control 
Data 
Insertar un Control DATA y no especificarle nada en la ventana de propiedades 
si se desea ver los datos en una grilla, insertar un "bound dbgrid" y asociarlo 
al Control Data 

Desde Código 

Menu Proyecto->Referencias Seleccionar DAO 3.6 

en algun procedimiento... 

Dim dbsdao36 As DAO.Database 
Dim rs As DAO.Recordset 

Set dbsdao36 = OpenDatabase("Base de Datos.mdb", False, False) 
Set rs = dbsdao36.OpenRecordset("Tabla") 
Set Data1.Recordset = rs 

Abrir Base de Datos de Access 2000 CON PassWord para asociarla con un Control 
Data 
Insertar un Control DATA y no especificarle nada en la ventana de propiedades 
si se desea ver los datos en una grilla, insertar un "bound dbgrid" y asociarlo 
al Control Data 

Desde Código 

Menu Proyecto->Referencias Seleccionar DAO 3.6 

en algun procedimiento... 

Dim dbsdao36 As DAO.Database 
Dim rs As DAO.Recordset 
Dim cPas As String 

cPas = ";pwd=password" 

Set dbsdao36 = OpenDatabase("Base de Datos.mdb", False, False, cPas) 
Set rs = dbsdao36.OpenRecordset("Tabla") 
Set Data1.Recordset = rs 
Abrir Base de Datos de Access 2000 SIN PassWord desde Código y Sin Data Control 

Menu Proyecto->Referencias Seleccionar DAO 3.6 

Dim dbsdao36 As DAO.Database 
Dim rsdao36 As DAO.Recordset 

Set dbsdao36 = OpenDatabase("C:\Via\ACCESS2000.MDB", True, False,) 
Set rsdao36 = dbs.OpenRecordset("Tabla") 

Abrir Base de Datos de Access 97 CON PassWord desde Código y Sin Data Control 
Menu Proyecto->Referencias Seleccionar DAO 3.6 

Dim dbsDao36 As DAO.Database 
Dim rsDao36 As DAO.Recordset 
Dim cPass as String 
Dim Clave as String 

Clave = "Password" 
cPass = ";PWD=" & Clave 

Set dbsDao36 = OpenDatabase("C:\Via\ACCESS2000.MDB", True, False, cPass) 'no se 
deben omitir el segundo ni el tercer Parámetro para que entre el password 
Set rsDao36 = dbs.OpenRecordset("Tabla") 

Abrir Base de Datos de Access 97 Sin PassWord para asociarla con un Control ADO 
Insertar un Control ADO 

Desde Código 

Dim Clave as String 
Clave = "" 

Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;" _ 
& "Data Source=" & "ACCESS97.MDB" & ";" _ 
& "Persist Security Info=False;" _ 
& "Jet OLEDB:Database Password=" & Clave 'jet 3.51 para access 97 

Adodc1.Mode = adModeRead ' elejir el modo 
Adodc1.RecordSource = "Tabla" 
Adodc1.Refresh 

Abrir Base de Datos de Access 97 con PassWord para asociarla con un Control ADO 
Insertar un Control ADO 

Desde Código 

Dim Clave as String 
Clave = "password" 

Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;" _ 
& "Data Source=" & "ACCESS97.MDB" & ";" _ 
& "Persist Security Info=False;" _ 
& "Jet OLEDB:Database Password=" & Clave 'jet 3.51 para access 97 

Adodc1.Mode = adModeRead ' elejir el modo 
Adodc1.RecordSource = "Tabla" 
Adodc1.Refresh 

Abrir Base de Datos de Access 2000 Sin PassWord para asociarla con un Control 
ADO 
Insertar un Control ADO 

Desde Código 

Dim Clave as String 
Clave = "" 

Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _ 
& "Data Source=" & "ACCESS97.MDB" & ";" _ 
& "Persist Security Info=False;" _ 
& "Jet OLEDB:Database Password=" & Clave 'jet 4.0 para access 2000 

Adodc1.Mode = adModeRead ' elejir el modo 
Adodc1.RecordSource = "Tabla" 
Adodc1.Refresh 

Abrir Base de Datos de Access 2000 Sin PassWord para asociarla con un Control 
ADO 
Insertar un Control ADO 

Desde Código 

Dim Clave as String 
Clave = "password" 

Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _ 
& "Data Source=" & "ACCESS97.MDB" & ";" _ 
& "Persist Security Info=False;" _ 
& "Jet OLEDB:Database Password=" & Clave 'jet 4.0 para access 2000 

Adodc1.Mode = adModeRead ' elejir el modo 
Adodc1.RecordSource = "Tabla" 
Adodc1.Refresh 

Añadir un base de datos a un servidor SQL
Mediante este ejemplo, podremos añadir una base de datos a un servidor SQL.
 PURPOSE: Creates a Database for an SQL Server
 PARAMETERS: ServerName: Name of SQLServer
 DatabaseName: Name of Database to Delete
 UserID: LoginID for SQL Server. 
 User must have sysadmin or
 dbcreator privileges
 Password: Password for SQL Server
 DatabaseFileName: FileName for Database
 AddTables: List of Tables to attach to the db. 
 If you don't want
 to add tables, pass "" as this parameter
 RETURNS: True if successful, false otherwise
 REQUIRES: Reference to Microsoft SQLDMO object library

 EXAMPLE: AddSQLDatabase "MySQLServer", "NewDB", "sa", "myPassword", _ 
"C:\Program Files\Microsoft SQL Server\MSSQL\Data\NewDB.mdf", "Newtable1", 
"NewTable2"

NOTES: Tested with SQL 2000. Should work with SQL 7.0

Public Function AddSQLDatabase(ByVal ServerName As String, ByVal DatabaseName As 
String, ByVal UserID As String, ByVal Password As String, ByVal DatabaseFileName 
As String, ParamArray AddTables() As Variant) As Boolean 
    Dim oSQLServer As New SQLDMO.SQLServer
    Dim oDatabase As New SQLDMO.Database
    Dim oDBFile As New SQLDMO.DBFile
    Dim oApp As New SQLDMO.Application
    Dim oFileGroup As SQLDMO.FileGroup
    Dim oTable As SQLDMO.Table
    Dim lCtr As Long
    Dim oColumn As SQLDMO.Column
    On Error GoTo ErrorHandler
    With oSQLServer
        .Connect ServerName, UserID, Password
        .Database.Name = DatabaseName
        ' This uses default properties of the dbfile. If you want to change 
these, set optional properties, such as MaximumSize
        .oDBFile.Name = DatabaseName
        .oDBFile.PhysicalName = DatabaseFileName
        .Set oFileGroup = oDatabase.FileGroups.Item("PRIMARY")
        .oFileGroup.DBFiles.Add oDBFile
        .Databases.Add oDatabase
            For lCtr = 0 To UBound(AddTables)
                If CStr(AddTables(lCtr)) <> "" Then
                    Set oTable = New SQLDMO.Table
                    oTable.Name = AddTables(lCtr)
                    'You must add at least one colummn.
                    'I'm adding a default identity col named
                    'id. If you want to control this,
                    'add more parameters to the function
                    Set oColumn = New SQLDMO.Column
                    oColumn.Datatype = "int"
                    oColumn.Identity = True
                    oColumn.Name = "ID"
                    oTable.Columns.Add oColumn
                    oDatabase.Tables.Add oTable
                End If
            Next
    End With
    AddSQLDatabase = True
    ErrorHandler:
    Set oSQLServer = Nothing
    Set oDatabase = Nothing
    Set oDBFile = Nothing
    Set oFileGroup = Nothing
End Function
Añadir una nueva tabla a una base de datos
Desde este código podremos crear una nueva tabla en una base de datos existente.
Public Function CreateTable(DatabaseName As String, ByVal TableName As String) 
As Boolean
    'DataBaseName es el path de su base de datos
    'TableName es el nombre de la tabla que quiere crear
    'Returns True si se crea o Falso en otro caso
    On Error GoTo errorhandler
    Dim oDB As DAO.Database
    Dim td As DAO.TableDef
    Dim f As DAO.Field
    Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
    On Error GoTo errorhandler
    If TableExists(oDB, TableName) Then GoTo errorhandler
    'Create table object
    Set td = oDB.CreateTableDef(TableName)
    'Debemos añadir un campo
    Set f = td.CreateField("ID", dbLong)
    f.Attributes = dbAutoIncrField
    td.Fields.Append f
    oDB.TableDefs.Append td
    oDB.Close
    CreateTable = True
    Exit Function
    errorhandler:
    If Not oDB Is Nothing Then oDB.Close
    Set td = Nothing
    Set f = Nothing
End Function

Private Function TableExists(oDB As Database, TableName As String) As Boolean
    Dim td As DAO.TableDef
    On Error Resume Next
    Set td = oDB.TableDefs(TableName)
    TableExists = Err.Number = 0
End Function
Añadir una nueva tabla a una base de datos(II)
Otra forma de añadir una nueva tabla en una base de datos de Microsoft Access.
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
Apertura mediante un control Data de una Base de Datos con Password

Este ejemplo nos muestra como abrir una base de datos desde Visual Basic 
protegida con contraseña.
Vamos a suponer que la base de datos se llama Bd1.mdb.
Genere una contraseña para la nueva base de datos creada.
Para este ejemplo, he creado la contraseña "Amb".
Tenga cuidado con las mayúsculas y minúsculas, ya que Access hace distinción 
entre ellas.

Se ha dispuesto para este ejemplo las siguientes propiedades de tabla:

Nombre de la tabla: Tabla1

Nombre del Campo  Tipo de datos  Tamaño:
    Nombre                   Carácter         50
    Apellido1                 Carácter         50
    Apellido2                 Carácter         50
    Edad                       Numérico        Entero

Ejemplo:

Añada 4 cajas de texto y un control Data al formulario, el cual por defecto 
llevará el nombre de Data1.
Cambie la propiedad DataSource de todas las cajas de texto a Data1.
A continuación escriba el siguiente código.

Private Sub Form_Load()
    Data1.DatabaseName = "C:\Temp\Bd1.mdb"
    Data1.RecordSource = "Tabla1"
    Data1.Connect = ";pwd=Amb" 
    Text1.DataField = "Nombre"
    Text2.DataField = "Apellido1"
    Text3.DataField = "Apellido1"
    Text4.DataField = "Edad"
End Sub 
Cambiar la localización de una BD de un DataEnvironment en tiempo de ejecución 
El siguiente ejemplo nos muestra cómo podemos cambiar la localización de una 
base de datos de un DataEnvironment en tiempo de ejecución. 
1. Obtenga la cadena de conexión que dió en tiempo de diseño: 

Debug.Print DE.Connections(1).ConnectionString

(DE es el nombre del DataEnvironment en el ejemplo),

2. En el inicio de su programa escriba algo similar al siguiente corte de 
código, preservando su cadena de conexión (modifica solo la localización de la 
base de datos, en este caso yo use la variable ArchivoBaseDeDatos)

Private Sub Form_Initialize()
    Dim s As String
    s = "Provider=MSDataShape.1;" & "Persist Security Info=False;" & "Data 
Source=" & ArchivoBaseDeDatos & ";" & "Data Provider=MICROSOFT.JET.OLEDB.4.0"
    DE.Connections(1).ConnectionString = s
End Sub 
Cargar los datos de un Recordset en un control MSFlexGrid 
A través de este ejemplo podremos cargar los datos de un Recordset en un control 
MsFlexGrid. 
Public Sub CargarGRID(Grid As MSFlexGrid, RST As Recordset)
    Dim NroColumnas, ActColumna As Long
    NroColumnas = Grid.Cols - 1
    Grid.Rows = 1
    Do While Not RST.EOF
        Grid.Rows = Grid.Rows + 1
        Grid.Row = Grid.Rows - 1
        For ActColumna = 0 To NroColumnas
            Grid.Col = ActColumna
            Grid.Text = RST.Fields(ActColumna)
        Next ActColumna
        RST.MoveNext
    Loop
End Sub

'Declaramos la variable de base de datos y recordset
Dim MiBD as Database
Dim MiRecordset as Recordset
Dim PathBaseDeDatos,NombreRecordset as String

'Abrimos la base de datos y establecemos el valor del recordset
PathBaseDeDatos=App.Path & "\MIBD.MDB"
'NombreRecordset puede ser el nombre de una tabla de la base de datos
'o bien una consulta SQL, por ejemplo:
' NombreRecordset="SELECT * FROM Alumnos;" 
NombreRecordset="Alumnos" 
Set MiBD=OpenDatabase(PathDeLaBaseDeDatos) 
Set MiRecordset=MiBD.OpenRecordset(NombreRecordset)

'Y ahora cargamos los datos ...
CargarGrid MSFlexGrid1, MiRecordset 
Cómo cerrar conexiones implícitas 
El ejemplo siguiente nos muestra cómo podemos con una sencilla rutina cerrar 
conexiones implícitas resultantes de abrir objetos recordsets independientes. 
En Visual Basic 6.0 es posible abrir objetos recordsets independientes sin 
asociarlos a ninguna conexión. Esto es posible gracias al carácter no jerárquico 
del modelo de programación de ADO. No obstante, cada vez que se abre un 
recordset de este tipo, se crea una conexión implícita. Esto supone que si el 
objeto recordset se cierra y se abre varias veces en el código del proyecto, se 
crearán tantas nuevas conexiones como veces se haya abierto el objeto recordset. 
Estas conexiones permanecerán abiertas hasta cerrar el proyecto.

Para impedir esto, y conseguir cerrar la conexión implícita a cada recordset 
independiente, se puede utilizar la siguiente técnica, que asocia a una variable 
Connection la conexión implícita a un recordset independiente, cerrando dicha 
conexión antes de reabrir el recordset. 

Dim rst1 As New ADODB.Recordset
Dim cnn As New ADODB.Connection

Private Sub Command1_Click()
    rst1.Open "authors", "Provider = sqloledb;Data Source=myServer;" & "Initial 
Catalog=pubs;User Id=sa;Password=;", adOpenStatic, adLockReadOnly
End Sub

Private Sub Command2_Click()
    Set cnn = rst1.ActiveConnection
    rst1.Close
    cnn.Close
    rst1.Open "publishers","Provider = sqloledb;Data Source=myServer;" & 
"Initial Catalog=pubs;User Id=sa;Password=;", adOpenStatic, adLockOptimistic
End Sub 
Compacta una base de datos de Access 
Mediante este código lograremos compactar una base de datos de Microsoft Access. 

Public Function compactDB(ByVal SOUR_path As String, ByVal DEST_path As String) 
As Boolean
    On Error GoTo Err_compact
    Private JRO As New JRO.JetEngine
    Private DB_sour As String, DB_dest As String 
    DoEvents
    DB_sour = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SOUR_path
DB_dest = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DEST_path & " ;Jet 
OLEDB:Engine Type=5"
    JRO.CompactDatabase DB_sour, DB_dest
    compactDB = True
    Exit Function
    Err_compact:
    compactDB = False
    MsgBox Err.Description, vbExclamation
End Function 
Compacta una base de datos de Access(II) 
Este es otro ejemplo de cómo compactar una base de datos de Access desde Visual 
Basic. 
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 
Comprobar la existencia de un campo en una BD 
El ejemplo siguiente nos muestra cómo podemos comprobar la existencia de un 
campo determinado dentro de una base de datos de Access. 
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 
Conectarnos a una base de datos de Internet 
Mediante el ejemplo siguiente podremos conectarnos a una base de datos que esté 
en Internet. 
server = "200.121.121.2" 'Tu servidor
source = "c:\temp\data1.mdb" 'El path de la base de datos
Adodc1.ConnectionString = "Provider=MS Remote;" & "Remote Server=" & server & 
";" & "Remote Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & source & ";" 
& "admin"

Consulta basica a una base de datos 

Este ejemplo consiste en una búsqueda mediante DAO en una base de datos.

Para este ejemplo, hemos creado una base de datos "Ciudad.mdb" con una tabla 
"Distritos" con dos campos "Ciudad" y "CodPostal".

Ejemplo:

Inserta el siguiente código: 

Private Sub Form_Load()
    Dim MiBase As Database
    Dim MiConsulta As Recordset
    Dim SQL As String
    Set MiBase = OpenDataBase("C:\Ciudad.Mdb")
    SQL = "Select * From Distritos Where CodPostal=28000"
    Set MiConsulta = MiBase.OpenRecordset(SQL)
    MsgBox "Ciudad: " & MiConsulta.Fields(0) & vbCrLf & "Código Postal: " & 
MiConsulta.Fields(1)
End Sub
Copiar tablas entre bases de datos
Mediante la siguiente rutina podremos copiar todas las tablas de una base de 
datos origen en una destino. Si las tablas ya existían en la base de datos de 
destino se eliminan y se vuelven a crear con la misma estructura que tuvieran en 
origen.
Las tablas de la base destino que no se encuentren en origen no se modifican.
Si el parámetro boCopiarDatos es true (valor por defecto) además de la 
estructura se copian los datos de las tablas.

Sub CopiaTablas(strOrigen As String, strDestino As String, Optional 
boCopiarDatos As Boolean = True)
    Dim dbOrigen As Database, dbDestino As Database
    Dim tdOrigen As TableDef, tdDestino As TableDef
    Dim fdOrigen As Field, fdDestino As Field
    Dim idOrigen As Index, idDestino As Index
    Dim prOrigen As Property, prDestino As Properties
    Dim i As Long
    Screen.MousePointer = vbHourglass
    'abrir origen y destino
    Set dbOrigen = OpenDatabase(strOrigen, False)
    Set dbDestino = OpenDatabase(strDestino, True)
    'hay propiedades que no se pueden copiar como el value de los campos, etc
    On Error Resume Next
    'para cada tabla de origen
    For Each tdOrigen In dbOrigen.TableDefs
        If (tdOrigen.Attributes And (dbSystemObject Or dbHiddenObject)) = 0 Then
            'si la tabla no es del sistema
            'mirar si existe la tabla en destino
            For Each tdDestino In dbDestino.TableDefs
                If tdDestino.Name = tdOrigen.Name Then
                    'si existe la borro
                    dbDestino.TableDefs.Delete tdDestino.Name
                    Exit For
                End If
            Next
            'creo la tabla en el destino
            Set tdDestino = dbDestino.CreateTableDef(tdOrigen.Name, 
tdOrigen.Attributes,             tdOrigen.SourceTableName, tdOrigen.Connect)
            'le añado los campos
            For Each fdOrigen In tdOrigen.Fields
                Set fdDestino = tdDestino.CreateField(fdOrigen.Name, 
fdOrigen.Type, fdOrigen.Size)
                'copio las propiedades del campo
                For Each prOrigen In fdOrigen.Properties
                    fdDestino.Properties(prOrigen.Name) = 
fdOrigen.Properties(prOrigen.Name)
                Next
                tdDestino.Fields.Append fdDestino
            Next
            'le añado los indices
            For Each idOrigen In tdOrigen.Indexes
                Set idDestino = tdDestino.CreateIndex(idOrigen.Name)
                'añado los campos al índice
                For Each fdOrigen In idOrigen.Fields
                    Set fdDestino = idDestino.CreateField(fdOrigen.Name)
                    idDestino.Fields.Append fdDestino
                Next
                'copio las propiedades del índice
                For Each prOrigen In idDestino.Properties
                    idDestino.Properties(prOrigen.Name) = 
idOrigen.Properties(prOrigen.Name)
                Next
                tdDestino.Indexes.Append idDestino
            Next
            dbDestino.TableDefs.Append tdDestino
            'copio los datos de la tabla, si se solicitó
            If boCopiarDatos Then dbOrigen.Execute ("INSERT INTO " + 
tdDestino.Name + " IN '" + strDestino + "' SELECT * FROM " + tdDestino.Name)
            End If
        Next
    'cerrar origen y destino
    dbOrigen.Close
    dbDestino.Close
    Set dbOrigen = Nothing: Set dbDestino = Nothing
    Set tdOrigen = Nothing: Set tdDestino = Nothing
    Set fdOrigen = Nothing: Set fdDestino = Nothing
    Set idOrigen = Nothing: Set idDestino = Nothing
    Set prOrigen = Nothing: Set prDestino = Nothing
    Screen.MousePointer = vbDefault
End Sub
Crear un índice en una propiedad personalizada
El siguiente artículo nos muestra cómo utilizar ActiveX Data Objects (ADO) para 
crear una propiedad personalizada que está indizada.
La información de este artículo se refiere a:
Microsoft Exchange 2000 Server
Collaboration Data Objects 6.0 para Exchange 2000
Microsoft Visual Basic Enterprise Edition para Windows 6.0
ActiveX Data Objects (ADO) 2.5, 2.6
ActiveX Data Objects (ADO) 2.5, 2.6

En este ejemplo de Visual Basic se muestran las siguientes tareas: 
Establece la definición de la propiedad 
urn:schemas-microsoft-com:exch-data:isindexed como TRUE. (Tenga en cuenta que 
esta configuración por sí sola no crea el índice.) El código que sigue al 
comentario "Create the property definition in the schema folder for title" 
indica cómo hacerlo. 
Define una clase de contenido que incluye la propiedad personalizada. El código 
que aparece bajo el comentario "Create the content class recipe" indica cómo 
hacerlo. 
Incluye dicha clase de contenido en la clase de contenido esperada de una 
carpeta. Esta carpeta suele ser la carpeta de aplicación que contiene los 
elementos en los que se encuentran los datos. El código que sigue al comentario 
"Setting the expected content class for the application folder (myapp)" indica 
cómo hacerlo. 
Utiliza CREATE INDEX para crear índices en todas las propiedades definidas en la 
clase de contenido esperada de la carpeta. (Esta función indiza todos los 
elementos de una carpeta, en lugar de indizarlos individualmente.) El código que 
sigue al comentario "Create indexes on all properties that are defined in the 
folder's expected content class" indica cómo hacerlo. 
Para ejecutar este ejemplo de código, siga estos pasos: 
Cree una carpeta llamada Myapp en el subárbol de carpetas públicas 
predeterminado y una subcarpeta de Myapp llamada Schema. 
Establezca una referencia a la biblioteca de tipos Active DS y a la biblioteca 
Microsoft ActiveX Data Objects 2.5. 
Copie el siguiente código a un módulo de Visual Basic: 
Const adModeReadWrite = 3
Const adFailIfNotExists = -1
Const adCreateNonCollection = 0

Private Sub Main()
    Dim Conn
    Dim Info
    Dim InfoNT
    Dim sFolderURL
    Dim sSchemaFolderURL
    Set Info = CreateObject("ADSystemInfo")
    Set InfoNT = CreateObject("WinNTSystemInfo")
    ' Path of Virtual Root.
    sVrootURL = "http://" & InfoNT.ComputerName & "." & Info.DomainDNSName & 
"/public"
    ' Path to the application folder.
    sFolderURL = sVrootURL & "/myapp"
    ' Path to the schema folder.
    sSchemaFolderURL = sVrootURL & "/myapp/schema"
    'This example creates an index on custom properties.
    ' The following property definitions are created:
    ' urn:schemas-domain-tld:title
    ' urn:schemas-domain-tld:ingredients
    ' These properties are used in the ' 
urn:schemas-domain-tld:content-classes:recipe content class.
    ' A URN scheme is used for the namespace: "urn:schemas-domain-tld:"
    ' where "tld" refers to "top-level domain".
    Set Conn = CreateObject("ADODB.Connection")
    Conn.Provider = "ExOLEDB.DataSource"
    Conn.Open sSchemaFolderURL
    Dim Rec
    Set Rec = CreateObject("ADODB.Record")
    ' Create the property definition in the schema folder for title.
    ' This property will be the indexed property; note that  
urn:schemas-microsoft-com:exch-data:isindexed is set to True.
    Rec.Open sSchemaFolderURL & "/title", Conn, adModeReadWrite, 
adCreateNonCollection
    Set Flds = Rec.Fields
    With Flds
        .Item("DAV:contentclass") = "urn:content-classes:propertydef"
        .Item("urn:schemas-microsoft-com:xml-data#name") = 
"urn:schemas-domain-tld:title"
        .Item("urn:schemas-microsoft-com:datatypes#type") = "string"
        .Item("urn:schemas-microsoft-com:exch-data:ismultivalued") = False
        .Item("urn:schemas-microsoft-com:exch-data:isindexed") = True
        .Item("urn:schemas-microsoft-com:exch-data:isreadonly") = False
        .Update
    End With
    Rec.Close
    ' Create the property definition in the schema folder for ingredients.
    Rec.Open sSchemaFolderURL & "/ingredients", Conn, adModeReadWrite, 
adCreateNonCollection
    Set Flds = Rec.Fields
    With Flds
        .Item("DAV:contentclass") = "urn:content-classes:propertydef"
        .Item("urn:schemas-microsoft-com:xml-data#name") = 
"urn:schemas-domain-tld:ingredients"
        .Item("urn:schemas-microsoft-com:datatypes#type") = "string"
        .Item("urn:schemas-microsoft-com:exch-data:ismultivalued") = True
        .Item("urn:schemas-microsoft-com:exch-data:isindexed") = False
        .Item("urn:schemas-microsoft-com:exch-data:isreadonly") = False
        .Update
    End With
    Rec.Close
    ' Create the content class recipe.
    Rec.Open sSchemaFolderURL & "/ccdef-recipe", Conn, adModeReadWrite, 
adCreateNonCollection
    Set Flds = Rec.Fields
    With Flds
        ' Name the content class.
        .Item("urn:schemas-microsoft-com:xml-data#name").Value = 
"urn:schemas-domain-tld:content-classes:recipe"
        ' The content class of the definition item.
        .Item("DAV:contentclass") = "urn:content-classes:contentclassdef"
        ' The content classes it extends (inherits from).
        .Item("urn:schemas-microsoft-com:xml-data#extends").Value = 
Array("urn:content-classes:item")
        ' The additional properties that belong to this content class.
        .Item("urn:schemas-microsoft-com:xml-data#element").Value = 
Array("urn:schemas-domain-tld:title",     "urn:schemas-domain-tld:ingredients")
        .Update
    End With
    Rec.Close
    Conn.Close
    ' Set properties on the application folder.
    Conn.Open sFolderURL
    Rec.Open sFolderURL, Conn, adModeReadWrite
    Set Flds = Rec.Fields
    With Flds
        .Item("urn:schemas-microsoft-com:exch-data:schema-collection-ref") = 
sSchemaFolderURL
        'Setting the expected content class for the application folder (myapp)
        .Item("urn:schemas-microsoft-com:exch-data:expected-content-class") = _
Array("urn:schemas-domain-tld:content-classes:recipe")
        .Update
    End With
    Rec.Close
    ' Set baseschema property on the schema folder.
    Rec.Open sSchemaFolderURL, Conn, adModeReadWrite
    Set Flds = Rec.Fields
    With Flds
        .Item("urn:schemas-microsoft-com:exch-data:baseschema") = 
Array(CStr("/public/non_ipm_subtree/Schema"))
        .Update
    End With
    Rec.Close
    ' Create indexes on all properties that are defined in the folder's expected 
content class.
    Conn.Execute "CREATE INDEX * ON """ & sFolderURL & """ (*)"
    ' Create an item in the application folder using these custom properties.
    Rec.Open sFolderURL & "/test1.txt", Conn, adModeReadWrite, 
adCreateNonCollection Or adCreateOverwrite
    Set Flds = Rec.Fields
    With Flds
        .Item("urn:schemas-domain-tld:title").Value = "Title of Recipe"
        .Item("urn:schemas-domain-tld:ingredients").Value = Array("ingredient1", 
"ingredient2", "ingredient3")
        .Item("DAV:contentclass") = 
"urn:schemas-domain-tld:content-classes:recipe"
        .Update
    End With
    Rec.Close
    Conn.Close
End Sub
Crear un nuevo campo en una bd de Access
Mediante la siguiente función podremos crear un nuevo campo en una base de datos 
de Access.
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 "SQL"
                    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
Crear un usuario para una base de datos de Access
Mediante este código podremos crear un usuario para una base de datos de 
Microsoft Access.
Const ADMIN_USERNAME = "Admin"
Const ADMIN_PASSWORD = "adminpass (or whatever)"
Const SHOWICON_STOP = 16
Const ADMIN_USERNAME = "Admin"
Const ADMIN_PASSWORD = "adminpass (or whatever)"
Const SHOWICON_STOP = 16

Function CreateNewUser% (ByVal username$, ByVal password$, ByVal PID$)
    ' Crea un nuevo usuario
    ' Username$ - nombre
    ' Password$ - password del usuario
    ' PID$ - PID del usuario
    Dim NewUser As User
    Dim admin_ws As WorkSpace
    ' Chequea el PID
    If (Len(PID$) < 4 Or Len(PID$) > 20) Then
        MsgBox "PID Inválido", SHOWICON_STOP
        CreateNewUser% = True
        Exit Function
    End If
    ' Verifica que el usuario no existe
    If (UserExist%(username$)) Then
        CreateNewUser% = True
        Exit Function
    End If
    ' Abre un nuevo workspace y base de datos como Admin
    dbEngine.Workspaces.Refresh
    Set admin_ws = dbEngine.CreateWorkspace("TempWorkSpace", ADMIN_USER, 
ADMIN_PASSWORD)
    If (Err) Then
        ' Error al abrir el workspace
        MsgBox "Password de Aministrador Inválida", SHOWICON_STOP
        MsgBox "Error: " & Error$, SHOWICON_STOP, SystemName
        CreateNewUser% = True
        Exit Function
    End If
    On Error Resume Next
    ' Crea el nuevo usuario
    Set NewUser = admin_ws.CreateUser(username$, PID$, password$)
    If (Err) Then
        MsgBox "Imposible crear el nuevo usuario", SHOWICON_STOP
        MsgBox Error$, SHOWICON_STOP
        Goto CreateNewUser_end
    End If
    ' Añade el usuario a la lista de usuarios
    admin_ws.Users.Append NewUser
    ' Añade al usuario al grupo "Users" 
    Set NewUser = admin_ws.CreateUser(username$)
    admin_ws.Groups("Users").Users.Append NewUser
    admin_ws.Users(username$).Groups.Refresh
    admin_ws.Close
    CreateNewUser% = False
    CreateNewUser_end:
    On Error Goto 0
End Function
Crear una base de datos de Access
A través del siguiente ejemplo, veremos cómo crear una base de datos de 
Microsoft Access desde Visual Basic.
Public Function CreateDatabase(DBFullPath As String, InitialTable As String) As 
Boolean
    'Crea una base de datos con una tabla
    Dim db As Database
    Dim td As TableDef
    Dim f As Field
    On Error GoTo ErrorHandler
    Set db = DBEngine.CreateDatabase(DBFullPath, dbLangGeneral)
    Set td = db.CreateTableDef(IntialTable)
    Set f = td.CreateField("ID", dbLong)
    td.Fields.Append f
    db.TableDefs.Append td
    CreateDatabase = True
    ErrorHandler:
    If Not db Is Nothing Then db.Close
End Function
Crear una base de datos de Access(II)
Este es otro ejemplo más que nos enseña cómo crear una base de datos de Access 
desde Visual Basic.
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
Determina si un campo existe dentro de una tabla de una base de datos de Access
Mediante el siguiente ejemplo comprobaremos la existencia de un campo 
determinado dentro de una tabla de una base de datos de Microsoft Access.
Public Function FieldExists(DatabaseName As String, TableName As String, 
FieldName As String) As Boolean
    Dim oDB As Database
    Dim td As TableDef
    Dim f As Field
    On Error GoTo errorhandler
    Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
    Set td = oDB.TableDefs(TableName)
    On Error Resume Next
    Set f = td.Fields(FieldName)
    FieldExists = Err.Number = 0
    oDB.Close
    Exit Function
    errorhandler:
    If Not oDB Is Nothing Then oDB.Close
    Err.Raise Err.Number
    Exit Function
End Function
Determina si una tabla existe en una base de datos de Access
Mediante este ejemplo comprobaremos la existencia de una tabla determinada en 
una base de datos de Microsoft Access.
Public Function TableExists(DatabaseName As String, TableName As String) As 
Boolean
    'DataBaseName = Nombre de la base de datos
    'TableName = Nombre de la tabla a buscar
    Dim oDB As Database, td As TableDef
    On Error GoTo errorhandler
    Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
    On Error Resume Next
    Set td = oDB.TableDefs(TableName)
    TableExists = Err.Number = 0
    oDB.Close
    exit function
    errorhandler:
    Err.Raise Err.Number
    Exit Function
End function
Determinar si existen relaciones en una BD de Access
Mediante el ejemplo siguiente podremos averiguar si existen relaciones en una 
base de datos de Access.
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 
Determinar si un RecordSet está o no vacio

A través de este ejemplo comprobaremos si un Recordset de nuestra BD está vacío. 

Ejemplo:

Inserta el siguiente código:

If Objeto_Recordset.BOF And Objeto_Recordset.EOF Then
    MsgBox "NO hay datos en la consulta"
Else
    MsgBox "Hay datos en la consulta."
End If 
Encriptar campos en las tablas de Access 
A través de este fenomenal ejemplo podremos encriptar los campos de una base de 
datos de Microsoft Access. 
Public encripta1 As String 
Public desencri1 As String 

Function ENCRIPTAR(valor As String) 
    Dim R As Integer 
    encripta1 = valor 
    R = Len(Trim(valor)) 
    For I = 1 To R 
        Mid(encripta1, I, 1) = Chr(Asc(Mid(valor, I, 1)) - 1) 
    Next I 
End Function 
Function DESENCRIPTAR(valor As String) 
    Dim R As Integer 
    desencri1 = valor 
    R = Len(Trim(valor)) 
    For I = 1 To R 
        Mid(desencri1, I, 1) = Chr(Asc(Mid(valor, I, 1)) + 1) 
    Next I 
End Function

'Para encriptar 

Call ENCRIPTAR(Text6.Text) 
TABLA10.Fields!REMITENTE = encripta1 

'Para desencriptar 

Call DESENCRIPTAR(TABLA10.Fields!CARGO) 
Text7.Text = desencri1 
Establece una contraseña para una base de datos de Access 
Mediante el siguiente ejemplo tendremos la oportunidad de establecer desde 
Visual Basic una contraseña a una base de datos de Microsoft Access. 
Public Function SetDatabasePassword(DBPath As String, newPassword As String) As 
Boolean
    'La base de datos debe estar inicialmente sin contraseña
    If Dir(DBPath) = "" Then Exit Function
    Dim db As DAO.Database
    On Error Resume Next
    Set db = OpenDatabase(DBPath, True)
    If Err.Number <> 0 Then Exit Function
    db.newPassword "", newPassword
    SetDatabasePassword = Err.Number = 0
    db.Close
End Function 
Exportar datos Sql a un fichero Csv 
El siguiente ejemplo nos enseña el método para poder exportar datos de un 
fichero Sql a uno con extensión Csv. 
Public Function CSVExport(db As DAO.Database, sSQL As String, sDest As String) 
As Boolean
    Dim record As Recordset
    Dim nI As Long
    Dim nJ As Long
    Dim nFile As Integer
    Dim sTmp As String
    On Error GoTo Err_Handler
    Set record = db.OpenRecordset(sSQL, DAO.dbOpenDynaset, DAO.dbReadOnly)
    ' Abre el fichero
    nFile = FreeFile
    Open sDest For Output As #nFile
    ' Exporta los campos
    For nI = 0 To record.Fields.Count - 1
        sTmp = "" & (record.Fields(nI).Name)
        Write #nFile, sTmp;
    Next
    Write #nFile,
    If record.RecordCount > 0 Then
        record.MoveLast
        record.MoveFirst
        For nI = 1 To record.RecordCount
            For nJ = 0 To record.Fields.Count - 1
                sTmp = "" & (record.Fields(nJ))
                Write #nFile, sTmp;
            Next
            Write #nFile,
            record.MoveNext
        Next
    End If
    Close #nFile
    CSVExport = True
    Exit Function
    Err_Handler:
    MsgBox ("Error: " & Err.Description)
    CSVExport = False
End Function 
Exporta la estructura de una tabla Oracle y su contenido a una base de datos de 
Access 
Este fenomenal ejemplo nos muestra un método para exportar la estructura y los 
datos de una base de datos de Oracle a una base de datos de Microsoft Access. 
Este ejemplo solo permite pasar datos numéricos y el tipo de datos "Varchar", 
además de tener que estar ya la base de datos creada o no funcionará.

Para comenzar el ejemplo añada un botón a su formulario:

Private Sub Command1_Click()
    Dim adoAccess As ADODB.Connection
    Dim rstAccess As ADODB.Recordset
    Dim adoOracle As ADODB.Connection
    Dim rstOracle As ADODB.Recordset
    Dim fldArray As Variant
    Dim tblName(2) As String
    Dim strSQL As String
    Dim strAlter As String
    Dim fld As ADODB.Field
    Dim rowNumber As Integer
    Dim fldNumber As Integer
    Set adoAccess = New ADODB.Connection
    Set rstAccess = New ADODB.Recordset
    rstAccess.CursorLocation = adUseClient
    Set adoOracle = New ADODB.Connection
    Set rstOracle = New ADODB.Recordset
    rstOracle.CursorLocation = adUseClient
    tblName(0) = "TEST_TABLE1"
    tblName(1) = "TEST_TABLE2"
    'La base de datos debe estar creada sin tablas
    adoAccess.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data 
Source=C:\Program Files\Microsoft " & "Visual Studio\VB98\testmdb.mdb"
adoAccess.Open
    'La base de datos de Oracle debe existir con el nombre de las tablas
    adoOracle.ConnectionString = "Provider=MSDAORA.1;Data Source=your_source;" & 
_
"User ID=my_id;Password=mypass"
    adoOracle.Open
    For a = 0 To UBound(tblName) - 1
        'Crea la tabla Access sin columnas
        adoAccess.Execute "create table " & tblName(a)
        'Lee la información de una columna de una tabla Oracle
        rstOracle.Open tblName(a), adoOracle, , , adCmdTableDirect
        MsgBox tblName(a)
        For Each fld In rstOracle.Fields
            Select Case fld.Type
            'Solo permite numérico y Varchar, en caso de necesitar más las 
añadiríamos a     continuación
                Case adNumeric
                    'Modifica la tabla para añadir una columna numérica
                    strAlter = "alter table " & tblName(a) & " add column " & 
fld.Name & " NUMBER"
                    adoAccess.Execute strAlter
                Case adVarChar
                    'Modifica la tabla para añadir una columna de texto
                    strAlter = "alter table " & tblName(a) & " add column " & 
fld.Name & " TEXT(" & fld.DefinedSize & ")"
                    adoAccess.Execute strAlter
            End Select
        Next fld
        rstOracle.Close
        'Selecciona todos los registros y los pone en un array
        strSQL = "select * from " & tblName(a)
        rstOracle.Open strSQL, adoOracle
        fldArray = rstOracle.GetRows
        'Abre la tabla Access
        rstAccess.Open tblName(a), adoAccess, adOpenKeyset, adLockOptimistic, 
adCmdTable
        For rowNumber = 0 To UBound(fldArray, 2)
            rstAccess.AddNew
            For fldNumber = 0 To rstAccess.Fields.Count - 1
                rstAccess(fldNumber) = fldArray(fldNumber, rowNumber)
            Next fldNumber
            rstAccess.Update
        Next rowNumber
        rstAccess.Close
        rstOracle.Close
    Next a
End Sub 
Exportar una base de datos de Access a Html 
A través del siguiente ejemplo, veremos como exportar los datos de la tabla de 
una base de datos de Microsoft Access a un fichero Html. 
Para ello añadiremos un botón y dos cajas de texto a un formulario.

Private Sub Command1_Click()
    Dim fnum As Integer
    Dim db As Database
    Dim rs As Recordset
    Dim num_fields As Integer
    Dim i As Integer
    Dim num_processed As Integer
    On Error GoTo MiscError
    ' Abre el fichero de salida
    fnum = FreeFile
    Open Text2.Text For Output As fnum
    ' Escribe la cabecera HTML
    Print #fnum, ""
    Print #fnum, ""
    Print #fnum, ""
    Print #fnum, ""
    Print #fnum, ""
    Print #fnum, ""
    Print #fnum, "My Title"
    ' Comienza la tabla HTML
    Print #fnum, ""
    ' Abre la base de datos
    Set db = OpenDatabase(Text1.Text)
    ' Ojo al SQL, haz los cambios necesarios
    Set rs = db.OpenRecordset("SELECT * FROM Table1 ORDER BY ID")
    Print #fnum, " " ' Comienza una columna
    num_fields = rs.Fields.Count
    For i = 0 To num_fields - 1
        Print #fnum, " ";
        Print #fnum, rs.Fields(i).Name;
        Print #fnum, " "
    Next i
    Print #fnum, " "
    Do While Not rs.EOF
        num_processed = num_processed + 1
        Print #fnum, " ";
        For i = 0 To num_fields - 1
            Print #fnum, " ";
            Print #fnum, rs.Fields(i).Value;
            Print #fnum, " "
        Next i
        Print #fnum, " ";
        rs.MoveNext
    Loop
    ' Cierra la tabla
    Print #fnum, " "
    Print #fnum, " "
    Print #fnum, " " & Format$(num_processed) & " records displayed."
    Print #fnum, ""
    Print #fnum, ""
    ' Cierra el fichero y la base de datos
    rs.Close
    db.Close
    Close fnum
    MsgBox "Procesado " & Format$(num_processed) & " registros."
    Exit Sub
    MiscError:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End Sub

Private Sub Form_Load()
    'Cambia a los nombres de tus ficheros
    Text1.Text = "C:\TuBasedeDatos.mdb"
    Text2.Text = "C:\TuFicheroHtml.htm"
End Sub

Exportar una o varias tablas a otro tipo de base de datos

Para  exportar una o varias tablas a otro tipo de base de datos, escribir lo 
siguiente.

Ejemplo:

Inicie un nuevo proyecto, añada un botón (nombre: Exportar).

Escriba el siguiente código para el formulario:

Private Sub Exportar_Click()
    Dim db As Database
    Set db = Workspaces(0).OpenDatabase(App.Path & "\Musica.mdb")
    'db.execute "SELECT tabla.campos INTO [tipo base de 
datos;DATABASE=path].[nombre del fichero a exportar]         FROM [tabla o 
tablas]
    db.execute "SELECT * INTO [dBase III;DATABASE=D:\Mis Documentos].[Musica] 
FROM [Disco]"
End Sub

Se exportará la tabla "Disco" en una base de datos con formato dBase III, y con 
nombre Musica.dbf. 
Exportar una tabla de Access a un fichero de Excel 
El siguiente ejemplo nos enseña cómo exportar los datos de una base de datos de 
Microsoft Access a una hoja de cálculo de Microsoft Excel. 
Private Sub ExportOneTable()
    'Deberemos referenciar DAO
    Dim strExcelFile As String
    Dim strWorksheet As String
    Dim strDB As String
    Dim strTable As String
    Dim objDB As Database
    'Cambiaremos estos datos de acuerdo a nuestras necesidades
    strExcelFile = "C:\My Documents\MySpreadSheet.xls"
    strWorksheet = "WorkSheet1"
    strDB = "C:\My Documents\MyDatabase.mdb"
    strTable = "MyTable"
    Set objDB = OpenDatabase(strDB)
    'Si el fichero excel existe, puedes borrarlo aqui
    If Dir(strExcelFile) <> "" Then Kill strExcelFile
    objDB.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & strExcelFile & "].[" & 
strWorksheet & "] FROM " & "[" & strTable & "]"
    objDB.Close
    Set objDB = Nothing
End Sub 
Extrae los nombres de todos los campos de la tabla de una Base de datos de 
Access 
A través de la siguiente rutina, podremos extraer los nombres de todos los 
campos de cualquier tabla en una base de datos de Microsoft Access. 
'dbPath = Nombre de la base de datos con su trayectoria
'TableName = Nombre de la Tabla

Public Function FieldNames(dbPath As String, TableName As String) As Collection
    Dim oCol As Collection
    Dim db As DAO.Database
    Dim oTD As DAO.TableDef
    Dim lCount As Long, lCtr As Long
    Dim f As DAO.Field
    On Error GoTo errorhandler
    Set db = workspaces(0).opendatabase(dbPath)
    Set oTD = db.TableDefs(TableName)
    Set oCol = New Collection
    With oTD
        lCount = .Fields.Count
        For lCtr = 0 To lCount - 1
            oCol.Add .Fields(lCtr).Name
        Next
    End With
    db.Close
    Set FieldNames = oCol
    Exit Function
    errorhandler:
    On Error Resume Next
    If Not db Is Nothing Then db.Close
    Set FieldNames = Nothing
    Exit Function
End Function 
Grabar una imagen en una BD de Access 
Mediante el ejemplo siguiente podremos grabar una imagen determinada en una base 
de datos de Access.

Sub GrabaImagenEnBD(f As adodb.Field, NombreImagen As String)
    Dim Fichero As Integer
    Dim LongitudFichero As Long
    Const TamañoBuffer = 1024
    Dim TamañoMinimo As Long
    Dim Bloques As Long
    Dim x() As Byte
    Dim i As Long
    On Error GoTo ErrorGrabaImagenEnBD
    Fichero = FreeFile
    Open NombreImagen For Binary Access Read As Fichero
    LongitudFichero = LOF(Fichero)
    Bloques = Int(LongitudFichero / TamañoBuffer)
    TamañoMinimo = LongitudFichero Mod TamañoBuffer
    ReDim x(TamañoMinimo)
    Get Fichero, , x()
    f.AppendChunk x()
    ReDim x(TamañoBuffer)
    For i = 1 To Bloques
        Get Fichero, , x()
        f.AppendChunk x()
    Next
    Close Fichero
    Exit Sub
    ErrorGrabaImagenEnBD:
    MuestraError "GrabaImagenEnBD", Err, Error
End Sub 
Introducir fotos en una BD sin DataControl 
Para introducir fotografías en una base de datos sin usar el control Data, 
bastará con ejecutar las siguientes líneas de código. 
Tenemos un recordset llamado MiRecordSet con un campo tipo OLE llamado MiCampo y 
un picture box llamado Picture1.

Para leer la imagen y mostrarla en el picture:

LeerBinary MiRecordSet!MiCampo, Picture1

Para guardar la imagen del picture en el campo:

GuardarBinary MiRecordSet!MiCampo, Picture1

Las funciones son:

Option Explicit
Dim DataFile As Integer
Dim Chunk() As Byte
Const conChunkSize As Integer = 16384

Public Sub LeerBinary(campoBinary As Field, unPicture As PictureBox)
    'Leer la imagen del campo de la base y asignarlo al Picture
    Dim lngCompensación As Long 
    Dim lngTamañoTotal As Long 
    'Se usa un fichero temporal para guardar la imagen 
    DataFile = FreeFile
    Open "pictemp" For Binary Access Write As DataFile 
    lngTamañoTotal = campoBinary.FieldSize
    Do While lngCompensación < lngTamañoTotal
        Chunk() = campoBinary.GetChunk(lngCompensación, conChunkSize)
        Put DataFile, , Chunk()
        lngCompensación = lngCompensación + conChunkSize 
    Loop 
    Close DataFile 
    'Ahora se carga esa imagen en el control
    unPicture.Picture = LoadPicture("pictemp") 
    'Ya no necesitamos el fichero, así que borrarlo
    On Local Error Resume Next 
    If Len(Dir$("pictemp")) Then
        Kill "pictemp" 
    End If 
    Err = 0
End Sub

Public Sub GuardarBinary(campoBinary As Field, unPicture As PictureBox)
    'Guardar el contenido del Picture en el campo de la base 
    Dim i As Integer
    Dim Fragment As Integer, Fl As Long, Chunks As Integer 
    'NOTA:
    ' El recordset debe estar preparado para Editar o Añadir
    'Guardar el contenido del picture en un fichero temporal
    SavePicture unPicture.Picture, "pictemp" 
    'Leer el fichero y guardarlo en el campo 
    DataFile = FreeFile
    Open "pictemp" For Binary Access Read As DataFile
    Fl = LOF(DataFile) ' Longitud de los datos en el archivo
    If Fl = 0 Then Close DataFile: Exit Sub 
    Chunks = Fl \ conChunkSize
    Fragment = Fl Mod conChunkSize 
    ReDim Chunk(Fragment) 
    Get DataFile, , Chunk() 
    campoBinary.AppendChunk Chunk()
    ReDim Chunk(conChunkSize) 
    For i = 1 To Chunks
        Get DataFile, , Chunk() 
        campoBinary.AppendChunk Chunk() 
    Next i
    Close DataFile 
    'Ya no necesitamos el fichero, así que borrarlo
    On Local Error Resume Next 
    If Len(Dir$("pictemp")) Then
        Kill "pictemp" 
    End If 
    Err = 0
End Sub 
Llamar a un programa del AS/400 para recuperar un registro Enviado por Rodolfo 
del Peru 
Mediante esta rutina podremos llamar a un programa del AS/400 para recuperar un 
registro. 
Sub Recupera_Cliente()
    Dim Rcds As Variant
    Dim Parms As Variant
    Dim cm As New ADODB.Command
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    Set cm.ActiveConnection = cnAS400
    'LibreriaProg es el nombre de la libreria en AS/400 donde reside el programa
    cm.CommandText = "{call LibreriaProg.PROGAS400(?)}"
    cm.Prepared = True
    cm.Parameters(0).Direction = adParamInput
    Parms = Array(Trim(txtCliente))
    Set rs = cm.Execute(Rcds, Parms, adCmdText) 
    With rs
        If .EOF Then
            MsgBox "Cliente no existe", vbExclamation, Me.Caption
            txtCliente.SetFocus
            txtNombre = ""
            txtDireccion1 = ""
        Else
            txtNombre = .Fields(2).Value
            txtDireccion1 = .Fields(3).Value
        End If
    End With
    rs.Close
End Sub

En el AS/400 el programa de tipo SQLRPG seria asi:
    C *ENTRY PLIST
    C PARM PCLI 7
    C/EXEC SQL INCLUDE SQLCA
    C/END-EXEC
    C/EXEC SQL DECLARE C1 CURSOR FOR
    c+ SELECT * FROM library/Archivo WHERE
    C+ CODCLI =: PCLI
    C/END-EXEC
    C/EXEC SQL OPEN C1
    C/END-EXEC
    C/EXEC SQL SET RESULT SETS CURSOR C1
    C/END-EXEC
    C SETON LR

Finalmente, el enlace entre el SQL del AS/400 y la PC esta dado por un 
Procedimiento almacenado, asi:

'LibreriaProg es el nombre de la libreria en AS/400 donde reside el programa 
create procedure LibreriaProg/PROGAS400(in CODIGO CHAR(7)) result set 1 external 
name LibreriaProg/PROGAS400 language RPG general variant 

Este procedimiento se crea entrando al AS/400 y dando el comando STRSQL. 
Modificar la contraseña de una base de datos 
A través del ejemplo siguiente, tendremos la oportunidad de modificar la 
contraseña de una base de datos existente. 
Public Function ChangeDatabasePassword(DBPath As String, newPassword As String, 
oldPassWord As String) As Boolean
    'Ejemplo ChangeDatabasePassword("C:\Ejemplo.mdb", "PassNueva", 
"PassAntigua")
    If Dir(DBPath) = "" Then Exit Function
    Dim db As DAO.Database
    On Error Resume Next
    Set db = OpenDatabase(DBPath, True, False, ";pwd=" & oldPassWord)
    If Err.Number <> 0 Then Exit Function
    db.newPassword oldPassWord, newPassword
    ChangeDatabasePassword = Err.Number = 0
    db.Close
End Function 
Modulo de consulta dinamica con agrupamientos

Con este módulo obtendremos la consulta de agrupamiento observando una serie de 
criterios que rellenaremos por el formulario. En este caso buscaremos atendiendo 
a la fecha (desde-hasta) y al departamento. Si la fecha o el departamento 
estuviesen vacíos, se cogerán todos los valores. Los agrupamientos (en este caso 
según meses, días o años) se colocarán fijos en un cuadro de lista y agrupamos 
atendiendo a la elección del agrupamiento.

El código del ejemplo:

Private Sub Command1_Click ()
    Dim Consref As QueryDef, Base1 As Database, Consulta2 As QueryDef
    Set Base1 = DbEngine.Workspaces(0).Databases(0)
    Base1.QueryDefs.Delete "Agrupacion"
    Base1.QueryDefs.Delete "Agrupacion del dia"
    Set Consref = Base1.CreateQueryDef()
    contador = 0
    Misql = "TRANSFORM SUM([" & [Campo4] & "]) As Total 
    SELECT Consulta1.Referencia,SUM([" & [Campo4] & "]) As 
    [Resumen de la fila] "
    Misql = Misql & "FROM Consulta1 "
    'Aqui filtramos los registros por fechas. 
    'Si Ambos filtros estan vacios, cogemos todos los valores. 
    'Si uno esta relleno, actuamos en consecuencia
    If Not (IsNull([Campo18])) Then
        If Not (IsNull([Campo20])) Then
            Condicion = " WHERE (movimientos.Fecha Between #" & 
            Format([Campo18], "mm/dd/yy") & "# AND #" & 
            Format([Campo20], "mm/dd/yy") & "#)"
        Else
            Condicion = " WHERE (movimientos.Fecha > #" & 
            Format([Campo18], "mm/dd/yy") & "#)"
        End If
    Else
        If Not (IsNull([Campo20])) Then
            Condicion = " WHERE (movimientos.Fecha < #" & 
            Format([Campo20], "mm/dd/yy") & "#)"
        Else
            contador = 1
        End If
    End If
    'Aqui colocamos la segunda opcion de filtrado, 
    que en este caso es por departamento. Si esta en blanco cogemos todos 
    los valores posibles
    If Not (IsNull([Campo15])) Then
        If contador = 1 Then
            Condicion = " WHERE Nombre LIKE " & Chr$(34) & [Campo15] & 
            Chr$(34) & " "
        Else
            Condicion = Condicion & " AND (Nombre LIKE " & Chr$(34) & 
            [Campo15] & Chr$(34) & ") "
        End If
    End If
    Misql = Misql & Condicion & "GROUP BY Consulta1.Referencia "
    'Aqui agrupamos por fechas pero basandonos 
    en un cuadro de lista con periodos especificos
    If [Campo2] = "Por mes" Then
        Misql = Misql & " PIVOT Format([Fecha]," & Chr$(34) & 
        "mm/yy" & Chr$(34) & ");"
    End If
    If [Campo2] = "Por año" Then
        Misql = Misql & " PIVOT Year([Fecha]);"
    End If
    If [Campo2] = "Por dia" Then
        Misql = Misql & " PIVOT Fecha;"
    End If
    Consref.Name = "Agrupacion"
    Consref.SQL = Misql
    Base1.QueryDefs.Append Consref
    Misql = "SELECT Agrupación.* From [Agrupacion] 
    ORDER BY [Resumen de la fila] DESC"
    Set Consulta2 = Base1.CreateQueryDef()
    Consulta2.SQL = Misql
    Consulta2.Name = "Agrupacion del dia"
    Base1.QueryDefs.Append Consulta2
    A = MsgBox("Consulta terminada", 64)
    Base1.Close
End Sub

Diccionario de datos
[Campo18]= Casilla de Texto. Seleccionamos la fecha desde.
[Campo20]= Casilla de Texto. Seleccionamos la fecha hasta.
[Campo15]= Cuadro de lista. Seleccionamos el departamento. El origen viene 
determinado por una consulta en la cual seleccionamos los departamentos.
[Campo2]= Cuadro de lista. Seleccionamos el tipo de agrupamiento. En este 
caso es por mes, día, año. Estos valores son fijos.


Modulo standard de busquedas dinamicas

Con el módulo de búsquedas dinámicas generaremos una consulta a partir de una 
serie de datos a través de los cuales deseamos realizar dicha consulta. Este 
módulo se apoya en un formulario independiente (no se apoya en ninguna tabla), 
en el cual se han colocado una serie de controles, normalmente cuadros de texto 
y cuadros de lista combinados, en los cuales colocaremos las opciones o 
parámetros sobre los cuales se realizará la búsqueda. Las razones para la 
utilización de este módulo son:

No se necesita conocer sobre qué tablas hay que hacer la consulta.
No se necesita conocer cómo crear consultas.
No hace falta tener una consulta creada para cada caso concreto.
Búsquedas más rápidas y flexibles: Se pueden rellenar todos, alguno o ninguno de 
los campos del formulario de la búsqueda.
Permite una impresión de la misma, realizar un gráfico o cambiar el origen de un 
formulario/informe a dicha consulta.

El código del ejemplo:

Option Compare Database 'Usar orden de base de datos en comparaciones de cadenas

Private Sub Command_Click ()
    Dim Mientrada As String, Misalida As String, Micriterio As String, 
    Origen As String, Contador1 As Integer
    Dim Tabla As Recordset, Basedatos As Database, Tabla2 As Recordset
    Set Basedatos = DbEngine.Workspaces(0).Databases(0)
    Set Tabla = Basedatos.OpenRecordset("Movimientos", DB_OPEN_DYNASET)
    Set Tabla2 = Basedatos.OpenRecordset("embalajes", DB_OPEN_DYNASET)
    Contador1 = 0
    Mientrada = "SELECT Movimientos.Cantidad, embalajes.articulo, 
    Movimientos.Fecha "
    Mientrada = Mientrada & "FROM embalajes INNER JOIN Movimientos 
    ON embalajes.articulo = Movimientos.Articulo"
    Misalida = Mientrada
    Mientrada = Mientrada & " WHERE ((Movimientos.Cantidad > 0)"
    Misalida = Misalida & " WHERE ((Movimientos.Cantidad < 0)"
    If IsNull([Campo0]) Then
        Micriterio = ""
    Else
        Micriterio = " AND (embalajes.articulo = [Campo0])"
    End If
    If [Campo2] <> "" Then
        If [Campo4] <> "" Then
            Micriterio = Micriterio & " AND 
            (Movimientos.Fecha Between [Campo2] AND [Campo4])"
        Else
            Micriterio = Micriterio & " AND 
            (Movimientos.Fecha >= [Campo2] )"
        End If
    Else
        If [Campo4] <> "" Then
            Micriterio = Micriterio & " AND 
            (Movimientos.Fecha <= [Campo4] )"
        End If
    End If
    If [Campo0] = "" And [Campo2] = "" And [Campo4] = "" Then
        Micriterio = ")"
    Else
        Micriterio = Micriterio & ") ORDER BY Movimientos.Fecha"
    End If
    MiOrigen = Mientrada & Micriterio
    Me![Incrustado10].Form.RecordSource = MiOrigen
    Me![Incrustado12].Form.RecordSource = Misalida & Micriterio 
End Sub

Es interesante observar como varian las instrucciones y 
parámetros de la consulta dependiendo del valor de los controles 
y como se usa el contenido de los mismos para utilizarlos en la 
instrucción SQL. Al final vemos como dicha instrucción SQL 
se utiliza para la propiedad OrigenDelRegistro (RecordSource) de dos 
subformularios que tiene el formulario de búsqueda.

Si quisiéramos añadir dicha consulta a las consultas de 
la base de datos entonces haríamos lo siguiente:

Dim Consref As QueryDef, Base1 As Database, Consulta2 As QueryDef
Set Base1 = Dbengine.Workspaces(0).Databases(0)
…….
Set Consulta2 = Base1.CreateQueryDef()
Consulta2.SQL = "SELECT Temporal1.* From [Temporal1]"
If [Campo15] = -1 Then
    Consulta2.SQL = Consulta2.SQL & " ORDER BY [Resumen de la fila] DESC"
End If
Consulta2.Name = "Temporal"
Base1.Querydefs.Append Consulta2 
Obtener los nombres de las tablas de una bd de Access 
Mediante el siguiente ejemplo podremos obtener los nombres de las tablas de una 
bd de Access, tanto si trabajamos con ADO como con DAO. 
Si trabajas en DAO: 

Dim db as Database 
'Abres la base de datos 
Dim tdf as TableDef 

For each tdf in db.TableDefs 
'Agrega el nombre al Listbox o a otro control usando la propiedad tdf.Name 
Next tdf 

Si trabajas en ADO:
Debes utilizar el ADOX. Para esto agrega la referencia a Microsoft ADO Ext. 2.5 
for Dll and Security.

Dim cn as new ADODB.Connection 
Dim ct as new ADOX.Catalog 
Dim tb as new ADOX.Table 

'Abres la conexión y el Catalog 
cn.open 'Connectiontring' 
Set ct.ActiveConnection = cn 

For each tb in ct.Tables 
'Agrega el nombre al Listbox o a otro control usando la propiedad tb.Name 
Next tb

Procedimiento para cargar las tablas de una Base de Datos en un ListBox

Estos dos ejemplos nos permiten cargar el contenido de las tablas de una base de 
datos en un ListBox.

Inserte un ListBox en un proyecto. Copie una de las siguientes rutinas de código 
en un módulo y llámelo desde el formulario. 
Suponemos que el fichero de la base de datos se llama Agentel.mdb :

Los dos procedimientos son formas de hacerlo diferentes. El segundo 
procedimiento es una forma más depurada aún de hacerlo.

Ejemplo:

1 Procedimiento

Public Sub CargarTablas()
    Dim I As Integer
    ' Declarada en el apartado Declaraciones : BD as Database 
    Set BD = Workspaces(0).OpenDatabase("Agentel.Mdb")
    ' Limpiamos el control ListBox donde cargamos las tablas 
    List1.Clear
    With BD
        For I = 0 To .TableDefs.Count - 1
            If Not Left(.TableDefs(I).Name, 4) = "MSys" Then
                List1.AddItem .TableDefs(I).Name
            End If
        Next I
    End With
End Sub

2 Procedimiento

Public Sub CargarTablas()
    Dim I As Integer
    ' Declarada en el apartado Declaraciones : BD as Database 
    Set BD = Workspaces(0).OpenDatabase("Agentel.Mdb")
    ' Limpiamos el control ListBox donde cargamos las tablas 
    List1.Clear
    With BD
        For I = 0 To .TableDefs.Count - 1
        ' Cargar sólo las tablas que no son del sistema 
            If .Tabledef.Attributes = 0 Then
                List1.AddItem .TableDefs(I).Name
            End If
        Next I
    End With
End Sub 
Realizar una consulta por Passthrough en RDO 
La técnica del "passthrough" permite enviar una consulta SQL a una base de datos 
sin necesidad de pasar por el administrador de ODBC. La ventaja principal de 
utilizar "passthrough" es obtener un mejor rendimiento ya que la consulta es 
procesada por menos componentes. Además, en ciertas ocasiones es necesario 
utilizar esta técnica cuando se utilizan sentencias SQL que no son estándar y 
son propietarias de una base de datos concreta.

El último parámetro de la instrucción "OpenResulset" permite pasar una consulta 
por "passthrough" especificando la constante "rdExecDirect".

El siguiente ejemplo muestra cómo ejecutar una consulta por "passthrough":


Dim cn as New rdoConnection
Dim rst as rdoResultset

cn.Connect="uid=sa;pwd=;server=SERVIDOR;_ 
driver=" & "{SQLServer};database=pubs;DSN=' ';"

cn.EstablishConnection rdDriverNoPrompt
Set rst=cn.OpenResultset("SELECT * FROM_
authors", rdOpenKeyset,rdConcurReadOnly, rdExecDirect) 
Recuperar una imagen grabada en una BD de Access 
Este ejemplo nos muestra cómo recuperar una imagen previamente grabada en una 
base de datos de Access. 
Sub CogeImagenDeBD(f As adodb.Field, NombreImagen As String)
    Dim Fichero As Integer
    Const TamañoBuffer = 1024
    Dim TamañoMinimo As Long
    Dim Bloques As Long
    Dim x() As Byte
    Dim i As Long
    On Error GoTo ErrorCogeImagenDeBD
    Fichero = FreeFile
    Open NombreImagen For Binary Access Write As Fichero
    Bloques = Int(f.ActualSize / TamañoBuffer)
    TamañoMinimo = f.ActualSize Mod TamañoBuffer
    x() = f.GetChunk(TamañoMinimo)
    Put Fichero, , x()
    For i = 1 To Bloques
        x() = f.GetChunk(TamañoBuffer)
        Put Fichero, , x()
    Next
    Close Fichero
    Exit Sub
    ErrorCogeImagenDeBD:
    MuestraError "CogeImagenDeBD", Err, Error
End Function 
Renombra una tabla de una base de datos de Access 
Mediante la siguiente rutina, podremos renombrar una tabla cualquiera de una 
base de datos de Microsoft Access. 
Public Function RenameTable(DatabaseName As String, ByVal OldTableName As 
String, _
ByVal NewTableName As String) As Boolean
    On Error GoTo errorhandler
    Dim oDB As DAO.Database
    Dim td As DAO.TableDef
    Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
    On Error GoTo errorhandler
    If Not TableExists(oDB, OldTableName) Then GoTo errorhandler
    If TableExists(oDB, NewTableName) Then GoTo errorhandler
    'Crea el objeto tabla
    Set td = oDB.TableDefs(OldTableName)
    td.Name = NewTableName
    oDB.TableDefs.Refresh
    oDB.Close
    RenameTable = True
    Exit Function
    errorhandler:
    If Not oDB Is Nothing Then oDB.Close
    Set td = Nothing
End Function 
Traspasar la información de una base de datos a un Combobox

Si quisiéramos pasar el contenido de un fichero de Base de Datos a un control 
ComboBox, podríamos hacerlo de la siguiente manera:

Ejemplo:

Inicie un nuevo proyecto en Visual Basic, añada un botón y escriba este código:

Private Sub Command1_Click()
    Dim DB As Database
    Dim SS As Snapshot
    Set DB = OpenDatabase("C:\BASE.MDB")
    Set SS = DB.CreateSnapshot("Infor")
    Do Until SS.EOF
    If Len(SS(0)) = 1 Then
        Combo1.AddItem SS(0) & " " & SS(1)
    Else
        Combo1.AddItem SS(0) & " " & SS(1)
    End If
    SS.MoveNext
    Loop
End Sub
Uso del control MSFlexGrid con ADO

El siguiente ejemplo, demuestra como conectar una base de datos con ADO a un 
control MSFlexGrid.

Ejemplo:

Inserte dos botones que nos servirán para conectar y desconectar la base de 
datos y acceder a los datos mediante ADO.

El programa abre una tabla denominada "Citas".

Modifique los datos que considere oportunos.

La información se mostrará en 25 campos o columnas dentro del control 
MSFlexGrid.

Escriba la siguiente función:

Dim Cn As New ADODB.Connection
Dim rs As ADODB.Recordset

Dim sSQL As String
Dim sOut As String

Private Sub Command1_Click()
    Dim ii As Long
    Dim oo As Integer
    If Cn.State = adStateOpen Then
        MsgBox "ADO Connection Successful!"
    End If
    sSQL = "Select * from Citas"
    rs.Open sSQL, Cn, adOpenDynamic
    sOut = ""
    ii = 0
    While rs.EOF <> True
    DBGrid1.Rows = ii + 1
    iii = 1
    For oo = 0 To 24
        DBGrid1.TextMatrix(ii, oo) = rs.Fields(oo)
    Next oo
    ii = ii + 1
    rs.MoveNext
    Wend
End Sub

Private Sub Command2_Click()
    rs.Close
    Set rs = Nothing
    Cn.Close
    Set Cn = Nothing
    Unload Me
End Sub

Private Sub Form_Load()
    Set Cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Cn.ConnectionString = "DSN=TESTRCH01;UID=ADOTRY;PWD=ADOTRY;"
    Cn.ConnectionTimeout = 100
    Cn.Open
End Sub
Principal