'------------------------------------------------------------------
'Código para grabar imagenes en campos de bases de datos
'------------------------------------------------------------------
Public Sub GuardarBinary(campoBinary As Field, unPicture As Image)
On Error GoTo GuardarBinary_Error

    '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

GuardarBinary_Done:
    Exit Sub
GuardarBinary_Error:
    Call SysException.error(MODULE_NAME, "GuardarBinary")
    Resume GuardarBinary_Done
End Sub


Public Function GetImage(ByVal Value As String, _
                           Optional ByVal fldIdentificacion As String = "Id", _
                           Optional ByVal fldContieneImagen As String = "Foto", _
                           Optional ByVal Catalog As String = "cEmpleados", _
                           Optional ByVal FName As String = "FotoE") As Boolean _


On Error GoTo GetImage_Error

    Dim Strm    As ADODB.Stream
    Dim RS      As ADODB.Recordset
    Dim sSQL$
    
    GetImage = False
    
    If LenB(fldContieneImagen$) = 0 Then Exit Function
    If LenB(Catalog$) = 0 Then Exit Function
    If LenB(FName$) = 0 Then Exit Function
    
    sSQL = "SELECT " & fldContieneImagen
    sSQL = sSQL & " FROM " & BDOPE & Catalog
    sSQL = sSQL & " WHERE"
    sSQL = sSQL & " " & fldIdentificacion & "=" & Value

    Set RS = DemiData.cnCentral.Execute(sSQL)
    
    If Not RecordsetVacio(RS) Then
            If Not IsNull(RS.Fields(fldContieneImagen)) Then
                    Set Strm = New ADODB.Stream
                    Strm.Type = adTypeBinary
                    Strm.Open
                    Strm.Write RS.Fields(fldContieneImagen).Value
                    Strm.SaveToFile FName, adSaveCreateOverWrite
                    GetImage = True
            End If
    End If

GetImage_Done:
  
  RecordsetCierra RS
  
  If Not Strm Is Nothing Then
       Strm.Close
       Set Strm = Nothing
  End If

  Exit Function

GetImage_Error:
  Call SysException.error(MODULE_NAME, "GetImage")
  Resume GetImage_Done
End Function

Public Function PutImage(ByVal FName As String, _
                      ByVal Value As Long, _
                      Optional ByVal fldIdentificacion As String = "id_maestros", _
                      Optional ByVal fldContieneImagen As String = "Foto", _
                      Optional ByVal Catalog As String = "Maestros", _
                      Optional ByVal FullSQL As String = vbNullString) As Boolean

On Error GoTo PutImage_Error

Dim Strm As ADODB.Stream
Dim RS As ADODB.Recordset
Dim sExistFile As String
Dim sSQL$
    
    PutImage = False
    
    If LenB(fldContieneImagen$) = 0 Then Exit Function
    If LenB(Catalog$) = 0 Then Exit Function
    If LenB(FName$) = 0 Then Exit Function
    
    If LenB(FullSQL) Then
            sSQL = FullSQL
        Else
            sSQL = "SELECT " & fldContieneImagen
            sSQL = sSQL & " FROM " & BDOPE & Catalog
            sSQL = sSQL & " WHERE"
            sSQL = sSQL & " " & fldIdentificacion & "=" & Value
    End If
    
    RS.Open sSQL, DemiData.cnCentral, adOpenDynamic, adLockOptimistic
    
    If Not RecordsetVacio(RS) Then
            Set Strm = New ADODB.Stream
                Strm.Type = adTypeBinary
                Strm.Open
                sExistFile = Dir$(FName)
                If LenB(sExistFile$) > 0 Then
                        Strm.LoadFromFile FName
                        RS.Fields(fldContieneImagen).Value = Strm.Read
                        RS.Update
                        PutImage = True
                End If
    End If

PutImage_Done:
  RecordsetCierra RS
  
  If Not Strm Is Nothing Then
       Strm.Close
       Set Strm = Nothing
  End If

  Exit Function

PutImage_Error:
  Call SysException.error(MODULE_NAME, "PutImage")
  Resume PutImage_Done

End Function