'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
Suscribirse a:
Enviar comentarios (Atom)
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 ...
-
Option Compare Database Option Explicit '***************************** ' 'Ejemplo de uso ' 'selecciona 1 ficher...
-
Option Compare Database Option Explicit 'Zip / UnZip file or folder 'http://www.codekabinett.com/rdumps.php?Lang=2&targetDoc...
No hay comentarios:
Publicar un comentario