martes, 3 de octubre de 2017

VBA Access. Listar en un formulario las imágenes de una tabla Sql Server.

'En un formulario tendremos un control imagen con origen de control: PathFName
'3 Textbox con orígenes de control: CodigoImagen, FName y KBSize

Private Sub LoadFormRecordset()
On Error GoTo error
    'Crear y abrir recordset dinamico al cual asignaremos valores y finalmente lo asignaremos al recordset del formulario
   'https://www.w3schools.com/asp/ado_datatypes.asp

    Dim rsD As New ADODB.Recordset
    rsD.Fields.Append "CodigoImagen", adInteger, , adFldKeyColumn
    rsD.Fields.Append "PathFName", adVarChar, 255, adFldIsNullable
    rsD.Fields.Append "FName", adVarChar, 255, adFldIsNullable
    rsD.Fields.Append "KBSize", adInteger, , adFldIsNullable
 
    rsD.CursorType = adOpenKeyset
    rsD.CursorLocation = adUseClient
    rsD.LockType = adLockPessimistic
    rsD.Open
     
    'Consultar BdD en otro recordset y extraer imagenes a ficheros
    Dim rsT As New ADODB.Recordset
    Dim cn As New ADODB.Connection
    cn.ConnectionString = DimeCadenaConexion
    cn.Open
 
    rsT.Open "SELECT CodigoImagen,NombreFichero,KBSize,Imagen FROM Imagenes", cn, adOpenStatic, adLockReadOnly
    If Not rsT.EOF Then
        'Crear carpeta temporal
        Dim sTempFolder As String
        sTempFolder = CurrentProject.Path & "\TempImgs"
     
        Dim fso As New FileSystemObject
        If Not fso.FolderExists(sTempFolder) Then fso.CreateFolder (sTempFolder)
     
        'Guardar imagen de bdd a fichero
        Dim str As New ADODB.Stream
        Dim objStream As New ADODB.Stream
        objStream.Type = adTypeBinary
        objStream.Open
             
        rsT.MoveFirst
        Dim i As Long
        For i = 1 To rsT.RecordCount
            objStream.Write rsT("Imagen")
            objStream.SaveToFile sTempFolder & "\" & fso.GetFileName(rsT("NombreFichero")), adSaveCreateOverWrite
         
            'Asignamos valores a recordset dinamico
            rsD.AddNew
            rsD!CodigoImagen = rsT("CodigoImagen")
            rsD!PathFName = sTempFolder & "\" & fso.GetFileName(rsT("NombreFichero"))
            rsD!FName = fso.GetFileName(rsT("NombreFichero"))
            rsD!KBSize = rsT("KBFichero")
            rsD.Update
         
            rsT.MoveNext
        Next i
     
        objStream.Close
        Set objStream = Nothing
 
        'asignar recordset dinamico al formulario
        Set Me.Recordset = rsD
     
    End If
    rsD.Close
    Set rsD = Nothing
    rsT.Close
    cn.Close
    Set rsT = Nothing

Exit Sub
Resume
error:
    MsgBox Err.Number & ": " & Err.Description
End Sub

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 ...