0
Gracias

Unas palabras de agradecimiento nunca están de más.

VBA VB6 - Leer todos los archivos, carpetas y subcarpetas



La función Scripting.FileSystemObject reemplaza ventajosamente a la función Application.FileSearch, que por otro lado ya no está disponible desde Office 2007.
Un ejemplo para almacenar todos los archivos de imágenes en una carpeta.
Pegar el código en un modulo .bas:

Option Explicit         
Dim Data()         
Dim NBdata As Integer         

`Obtener todos los archivos de una carpeta y subcarpetas
'Si SubCarp = true         
`La carpeta de origen debe estar en Carp
Public Function LeerCarpeta (ByVal Carp As String, Optional SubCarp As Boolean) As Integer         
Dim Obj, CarpP, F, S, sf, F1, Fsub      
Dim i As Integer, Ext As String         
Dim Ruta As String         
Dim T As Double         
   ' Application.MousePointer = 13 'Para VB6        
    Set Obj = CreateObject("Scripting.FileSystemObject")         
    Set RepP = Obj.Getfolder(Carp)         
    Chem = Carp: If Right(Ruta, 1) <> "\" Then Ruta = Ruta & "\"         
             
    Set sf = CarpP.subfolders         
    Set F = CarpP.Files         
    GoSub RellenarData 'los archivos de la carpeta principal         
    If SubCarp Then 'los archivos de las subcarpetas
        For Each FSub In sf         
            Set CarpP = Fsub         
            Set F = CarpP.Files         
            GoSub RellenarData         
        Next Fsub         
    End If         
Exit Function         
'**********************************************************************         
RellenarData:         
    For Each F1 In F         
        Ext = LCase(Right(F1.Name, 3))         
        If Ext = "bmp" Or Ext = "jpg" Then 'extensión a adaptar         
            ReDim Preserve Data(5, NBdata)         
            Data(0, NBdata) = F1.Name         
            Data(1, NBdata) = F1.ParentFolder & "\" & F1.Name         
            Data(2, NBdata) = F1.DateCreated         
            Data(3, NBdata) = F1.DateLastAccessed         
            Data(4, NBdata) = F1.DateLastModified         
            T = F1.Size         
            If T < 99999 Then         
                Data(5, NBdata) = T & " Bi"         
            ElseIf T < 999999 Then         
                Data(5, NBdata) = Round(T / 1000, 1) & " Ko"         
            Else         
                Data(5, NBdata) = Round(T / 1000000, 1) & " Mo"         
            End If         
            NBdata = NBdata + 1         
        End If         
    Next F1         
Return         
             
End Function


También es posible guardar información de los archivos
Adaptar el código de acuerdo a las necesidades.

0
Gracias

Unas palabras de agradecimiento nunca están de más.

Haz una pregunta
Nuestros contenidos son redactados en colaboración con expertos del ámbito tecnológico bajo la dirección de Jean-François Pillou, fundador de CCM.net y director digital en el Grupo Figaro. CCM es un sitio de tecnología líder a nivel internacional y está disponible en 11 idiomas.

0 Comentario