Option Explicit

'
' El procedimiento guardará la imagen indicada en la ruta del archivo
' en el valor del campo pasado. 
'
Private Sub SaveBinaryFile(fld As ADODB.Field, ByVal strFileName As String)

    Dim x As Long, iFile As Integer
    Dim lSize As Long, lChunks As Long
    Dim Chunk() As Byte
    Const Buffer As Long = 16384&

    On Error GoTo ErrSaveBinaryFile

    ' El objeto Recordset deberá estar dispuesto para
    ' Añadir o Editar datos, ya que de lo contrario
    ' fallará el método AppendChunk

    ' Abrimos el archivo para leerlo
    iFile = FreeFile
    Open strFileName For Binary Access Read As iFile

    ' Si el tamaño del archivo es cero, salimos del procedimiento
    lSize = LOF(iFile)
    If lSize = 0 Then
        Close iFile
        Exit Sub
    End If

    ' Calculamos los trozos que componen el archivo
    ReDim Chunk(lSize Mod Buffer)
    lChunks = lSize \ Buffer

    ' Leemos el archivo gráfico indicado ...
    Get iFile, , Chunk()

    ' ... y vamos añadiendo los datos al objeto Field
    fld.AppendChunk Chunk()

    ReDim Chunk(Buffer)
    For x = 1 To lChunks
        Get iFile, , Chunk()
        fld.AppendChunk Chunk()
    Next x

ErrSaveBinaryFile:

    ' Si se ha producido algún error, mostramos
    ' la descripción del mismo
    If Err.Number Then
        MsgBox Err.Description, vbInformation, "Guardar archivo binario"
    End If

    ' Cerramos el archivo
    Close iFile

End Sub
 

Para ejecutar el procedimiento, bien podríamos utilizar el siguiente ejemplo:


Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset

' Creamos un nuevo objeto Connection
Set cnn = New ADODB.Connection

' Configuramos y abrimos la conexión 
With cnn
    .Provider="Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=C:\Mis documentos\bd1.mdb"
    .Open
End With

' Creamos una tabla nueva para probar el ejemplo
cnn.Execute "CREATE TABLE Tabla1(" & _
            "Foto LONGBINARY)"

' Creamos un nuevo objeto Recordset
Set rst = New ADODB.Recordset

' Configuramos y abrimos el objeto Recordset
With rst
    .CursorType = adOpenKeyset
    .LockType = adLockOptimistic
    .Open "Tabla1", cnn, , , adCmdTable

    ' Añadimos un nuevo registro
    .AddNew

    ' Guardamos el valor del campo
    SaveBinaryFile rst.Fields!Foto, "C:\Mis imágenes\Margaritas.bmp"

    ' Actualizamos el conjunto de registros
    .Update
End With

' Mostramos la image
Set Image1.DataSource = rst
Image1.DataField = "Foto"