viernes, 29 de septiembre de 2017

VBA Access. Funciones para guardar imagen a Bdd, leer de Bdd y volcar a fichero, leer de Bdd y mostrar en un control Imagen del formulario.

' SQL Server, Tabla Imagenes
' [Id] [int] NOT NULL,
' [Descripcion] [nvarchar](250) NULL,
' [Imagen] [varbinary](max) NULL,

Function AddFileImageToBdd(ByVal Id As Long, ByVal sDescripcion As String, ByVal sFName As String) As Boolean
On Error GoTo error
    Dim rs As ADODB.Recordset
    Dim objStream As New ADODB.Stream
 
    'create the stream
    objStream.Type = adTypeBinary
    objStream.Open
    objStream.LoadFromFile sFName
 
    Set rs = GetRecordset("SELECT TOP 0 * FROM Imagenes")
    With rs
        .AddNew
        !Id = Id
        !Descripcion = sDescripcion
        !Imagen = objStream.Read
        .Update
        .Close
    End With
    Set rs = Nothing
    objStream.Close
    Set objStream = Nothing
 
    AddFileImageToBdd = True
 
Exit Function
error:
    AddFileImageToBdd = False
    Debug.Print Err.Description
End Function

Function ReadFileImageBdd(ByVal Id As Long, ByVal sDescripcion As String, ByVal sFName As String) As Boolean
On Error GoTo error
    Dim rs As ADODB.Recordset
    Dim objStream As New ADODB.Stream
 
    'create the stream
    objStream.Type = adTypeBinary
    objStream.Open
 
    Set rs = GetRecordset("SELECT Imagen FROM Imagenes WHERE Id = " & Id)
    If Not rs.EOF Then
        objStream.Write rs!Imagen
        objStream.SaveToFile sFName, adSaveCreateOverWrite
    End If
    rs.Close
    Set rs = Nothing
    objStream.Close
    Set objStream = Nothing
 
    ReadFileImageBdd = True
 
Exit Function
error:
    ReadFileImageBdd = False
    Debug.Print Err.Description
End Function

Function ReadFileImageBddToPicture(ByVal Id As Long, ByRef ImgCtl As image) As Boolean
On Error GoTo error
    Dim rs As ADODB.Recordset
    Dim objStream As New ADODB.Stream
 
    'create the stream
    objStream.Type = adTypeBinary
    objStream.Open
 
    Set rs = GetRecordset("SELECT Imagen FROM Imagenes WHERE Id = " & Id)
    If Not rs.EOF Then
        objStream.Write rs!Imagen
        objStream.Position = 0
        ImgCtl.PictureData = objStream.Read  ' load bytes into Image control on form
    End If
    rs.Close
    Set rs = Nothing
    objStream.Close
    Set objStream = Nothing
 
    ReadFileImageBddToPicture = True
 
Exit Function
Resume
error:
    ReadFileImageBddToPicture = False
    Debug.Print Err.Description
End Function

No hay comentarios:

Publicar un comentario

VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)

 Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double     'Aplica método medio redondeo (half round ...