************************************ *Recopilado por el Buho de la Web: *http://www.terra.es/personal2/sfortiz/ ************************************ Graba Imagen en BD ================== 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 Coge Imagen de BD ================= 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 Form_Load Private Sub Form_Load() Adodc2.Refresh Adodc2.Recordset.AddNew Call GrabaImagenEnBD(Adodc2.Recordset!imagen, App.Path & "\imagen.bmp") Adodc2.Recordset.Update Adodc2.Refresh If Adodc2.Recordset.RecordCount > 0 Then Adodc2.Recordset.MoveLast Call CogeImagenDeBD(Adodc2.Recordset!imagen, App.Path & "\temp.bmp") End If Picture1.Picture = LoadPicture(App.Path & "\temp.bmp") Adodc2.Refresh Adodc2.Recordset.MoveFirst End Sub