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.
Véase también
Comunidad de asistencia y consejos.
El artículo original fue escrito por
lermite222. Traducido por
Carlos-vialfa.
