domingo, 1 de octubre de 2017

VBA Access. Mostrar todas las imágenes de una carpeta y sus subdirectorios en un formulario continuo utilizando un recordset dinámico.

Option Compare Database
Option Explicit

'Visualizar todas las imágenes de una carpeta y subcarpetas en un formulario
'
'Construimos un formulario con
'encabezado formulario:
'1 botón de comando
'
'detalles formulario:
'1 control imagen y origen del control llamado Img
'3 textbox con origen del control FName, PathFName y Order
'
'configurar el formulario en formularios continuos


Private Enum MsoFileDialogType
    msoFileDialogOpen = 1           'Permite al usuario abrir un archivo.
    msoFileDialogSaveAs = 2         'Permite al usuario guardar un archivo.
    msoFileDialogFilePicker = 3     'Permite al usuario seleccionar un archivo.
    msoFileDialogFolderPicker = 4   'Permite al usuario seleccionar una carpeta.
End Enum

Private Function SelectItem(ByVal tipo As MsoFileDialogType) As String
On Error GoTo error
    Dim fDialog As Object
    Dim intResult As Integer
    Dim strPath As String
    strPath = ""

    Set fDialog = Application.FileDialog(tipo)

    intResult = Application.FileDialog(tipo).Show
    If intResult <> 0 Then
        strPath = Application.FileDialog(tipo).SelectedItems(1)
    End If

    SelectItem = strPath

Exit Function
error:
    SelectItem = ""
    MsgBox Err.Description
End Function

Private Sub cmdLoadFolderImageToPictures_Click()
    Dim res As Boolean
    Dim sFPathFolder  As String
    sFPathFolder = SelectItem(msoFileDialogFolderPicker)
    If sFPathFolder = "" Then Exit Sub

    Dim oFileList As New clsFileList
    res = oFileList.GetFileList(sFPathFolder)
    If Not res Then Exit Sub

    Dim rs As New ADODB.Recordset
    With rs
        .Fields.Append "PathFName", adVarChar, 255, adFldKeyColumn
        .Fields.Append "FName", adVarChar, 255, adFldIsNullable
        .Fields.Append "Img", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order", adInteger, , adFldIsNullable
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockPessimistic
        .Open
    End With

    Dim fso As New FileSystemObject
    Dim i As Long
    For i = 1 To oFileList.FilesCount
        rs.AddNew
        rs!FName = fso.GetFileName(oFileList.Files(i))
        rs!PathFName = oFileList.Files(i)
        rs!Img = oFileList.Files(i)
        rs!Order = i
        rs.Update
    Next i
    Set fso = Nothing

    'rs.Sort = "PathFname,FName"
    rs.Sort = "FName"

    Set Me.Recordset = rs
    rs.Close
    Set rs = Nothing

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