lunes, 2 de octubre de 2017

VBA Access. Mostrar todas las imágenes en 5 columnas 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 simulando 5 registros por fila
'
'Construimos un formulario con
'encabezado formulario:
'1 botón de comando para seleccionar la carpeta con las imagenes
'
'detalles formulario:
'5 controles imagen1,imagen2,imagen3,imagen4,imagen5 y origen del control llamados Img_1,Img_2,Img_3,Img_4,Img_5 en cada uno de ellos
'5 botones transparentes encima de cada imagen
'Por cada imagen, debajo añadimos, 3 textbox con origen del control FName,PathFName,Order, para la segunda imagen FName_2,PathFName_2,Order_2, ...
'
'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 cmbButton1_Click()
    MsgBox Me.PathFName

End Sub

Private Sub cmbButton2_Click()
    MsgBox Me.PathFName_2

End Sub

Private Sub cmbButton3_Click()
    MsgBox Me.PathFName_3

End Sub

Private Sub cmbButton4_Click()
    MsgBox Me.PathFName_4

End Sub

Private Sub cmbButton5_Click()
    MsgBox Me.PathFName_5

End Sub

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 "FName", adVarChar, 255, adFldIsNullable
        .Fields.Append "PathFName", adVarChar, 255, adFldKeyColumn
        .Fields.Append "Img", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order", adInteger, , adFldIsNullable
     
        .Fields.Append "FName_2", adVarChar, 255, adFldIsNullable
        .Fields.Append "PathFName_2", adVarChar, 255, adFldKeyColumn
        .Fields.Append "Img_2", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order_2", adInteger, , adFldIsNullable
     
        .Fields.Append "FName_3", adVarChar, 255, adFldIsNullable
        .Fields.Append "PathFName_3", adVarChar, 255, adFldKeyColumn
        .Fields.Append "Img_3", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order_3", adInteger, , adFldIsNullable
     
        .Fields.Append "FName_4", adVarChar, 255, adFldIsNullable
        .Fields.Append "PathFName_4", adVarChar, 255, adFldKeyColumn
        .Fields.Append "Img_4", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order_4", adInteger, , adFldIsNullable
     
        .Fields.Append "FName_5", adVarChar, 255, adFldIsNullable
        .Fields.Append "PathFName_5", adVarChar, 255, adFldKeyColumn
        .Fields.Append "Img_5", adVarChar, 255, adFldIsNullable
        .Fields.Append "Order_5", adInteger, , adFldIsNullable
     
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockPessimistic
        .Open
    End With

    Dim nRecords As Long
    nRecords = oFileList.FilesCount
    Dim fso As New FileSystemObject
    Dim i As Long
    Dim j As Integer
    For i = 1 To nRecords
            rs.AddNew
         
            rs!FName = fso.GetFileName(oFileList.Files(i))
            rs!PathFName = oFileList.Files(i)
            rs!Img = oFileList.Files(i)
            rs!Order = i
         
            j = 0
            j = i + 1
            If j <= nRecords Then
                rs!FName_2 = fso.GetFileName(oFileList.Files(j))
                rs!PathFName_2 = oFileList.Files(j)
                rs!Img_2 = oFileList.Files(j)
                rs!Order_2 = j
            End If
         
            j = j + 1
            If j <= nRecords Then
                rs!FName_3 = fso.GetFileName(oFileList.Files(j))
                rs!PathFName_3 = oFileList.Files(j)
                rs!Img_3 = oFileList.Files(j)
                rs!Order_3 = j
            End If
         
            j = j + 1
            If j <= nRecords Then
                rs!FName_4 = fso.GetFileName(oFileList.Files(j))
                rs!PathFName_4 = oFileList.Files(j)
                rs!Img_4 = oFileList.Files(j)
                rs!Order_4 = j
            End If
         
            j = j + 1
            If j <= nRecords Then
                rs!FName_5 = fso.GetFileName(oFileList.Files(j))
                rs!PathFName_5 = oFileList.Files(j)
                rs!Img_5 = oFileList.Files(j)
                rs!Order_5 = j
            End If
         
            rs.Update
     
            i = j
    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 ...