Option Compare Database
Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Type PT
Width As Integer
 Height As Integer
End Type


Type OBJECTHEADER
 Signature As Integer
 HeaderSize As Integer
 ObjectType As Long
 NameLen As Integer
 ClassLen As Integer
 NameOffset As Integer
 ClassOFfset As Integer
 ObjectSize As PT
 OleInfo As String * 256
End Type
 
Function Prueba()
Dim Rso As New ADODB.Recordset
Dim CampoOle As ADODB.Field
Dim SqlTxt As String
SqlTxt = "Select Foto From TablaBuhoFoto"
Rso.Open SqlTxt, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If Not Rso.EOF Then
   Set CampoOle = Rso(0)
   Call CrearBitmap(CampoOle)
Else
   MsgBox "No existe registro"
End If
MsgBox "FIN"
Rso.Close
Set Rso = Nothing
End Function
 
Sub CrearBitmap(ByVal OleField As ADODB.Field) 'OleField ha de contener Imagen BMP
Dim Arr() As Byte
Dim ObjHeader As OBJECTHEADER
Dim Buffer As String, DiskFile As String
Dim ObjectOffset As Long
Dim BitmapOffset As Long
Dim BitmapHeaderOffset As Integer
Dim ArrBmp() As Byte
Dim i As Long
'Redimensiona el array y lo rellena con todo
'el contenido del campo
'ReDim Arr(OleField.FieldSize)
'Arr() = OleField.GetChunk(0, OleField.FieldSize)
ReDim Arr(OleField.ActualSize)
Arr() = OleField.GetChunk(OleField.ActualSize)
'Copia los primeros 19 bytes a una variable
'del tipo OBJECTHEADER.
CopyMemory ObjHeader, Arr(0), 19
'Determina dónde acaba la cabecera.
ObjectOffset = ObjHeader.HeaderSize + 1
'Coge suficientes bytes después de la cabecera OLE
'para obtener la cabecera del bitmap
Buffer = ""
For i = ObjectOffset To ObjectOffset + 512
    Buffer = Buffer & Chr(Arr(i))
Next i
   
   
   BitmapHeaderOffset = InStr(Buffer, "BM~")
   If BitmapHeaderOffset > 0 Then
'Calcula el cominezo del bitmap
      BitmapOffset = ObjectOffset + BitmapHeaderOffset - 1
'Mueve el bitmap en su propio array
      ReDim ArrBmp(UBound(Arr) - BitmapOffset)
      CopyMemory ArrBmp(0), Arr(BitmapOffset), UBound(Arr) - _
      BitmapOffset + 1
'Devuelve el bitmap
      Dim DestFileNum As Integer
      DestFileNum = FreeFile
      DiskFile = "C:\fotobuho.bmp"
      Open DiskFile For Binary As DestFileNum
      Put DestFileNum, , ArrBmp()
      Close DestFileNum
   Else
      MsgBox "BitmapHeaderOffset = 0"
   End If

End Sub