A função
Scripting.FileSystemObject substitui, vantajosamente, a função
Application.FileSearch que, aliás, não está mais disponível no Office 2007.
Um exemplo para salvar todos os arquivos de imagens de um diretório.
Colar em um módulo .bas :
Option Explicit
Dim Data()
Dim NBdata As Integer
'Obter todos os arquivos de um diretório e, se for o caso, dos subdiretórios
'Si Subdiretório = true
'O diretório de origem deve ficar em Rep
Public Function LerDiretório (ByVal Rep As String, Optional SousRep As Boolean) As Integer
Dim Obj, RepP, F, S, sf, F1, Fsous
Dim i As Integer, Ext As String
Dim Chem As String
Dim T As Double
' Application.MousePointer = 13 'Pour VB6
Set Obj = CreateObject("Scripting.FileSystemObject")
Set RepP = Obj.Getfolder(Rep)
Chem = Rep: If Right(Chem, 1) <> "\" Then Chem = Chem & "\"
Set sf = RepP.subfolders
Set F = RepP.Files
GoSub RempliData 'os arquivos do diretório principal
If SousRep Then 'os arquivos dos sub- diretórios
For Each Fsous In sf
Set RepP = Fsous
Set F = RepP.Files
GoSub RempliData
Next Fsous
End If
Exit Function
'**********************************************************************
RempliData:
For Each F1 In F
Ext = LCase(Right(F1.Name, 3))
If Ext = "bmp" Or Ext = "jpg" Then 'extention à 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
Salve também as informações nos arquivos.
Adaptar conforme suas necessidades.
A ver igualmente
Comunidade de assistência e de conselho.
Artigo original publicado por
lermite222. Tradução feita por
pintuda.
