Domine o Excel ® (3 em 1): Excel - 70 Fórmulas Incríveis, Excel - 51 Macros incríveis e 51 Dicas e Truques Incríveis

Function ProcurarArquivos(ByVal sPath As String, ByRef sFoundFiles() As
String,
ByRef iArqEncontrados As Integer,
Optional ByVal sFileSpec As String = ".", _
Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean
Dim iContador As Integer
Dim sFileName As String
Dim oFileSystem As Object, oParentFolder As Object, oFolder As Object
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oParentFolder = oFileSystem.GetFolder(sPath)
If oParentFolder Is Nothing Then
ProcurarArquivos = False
On Error GoTo 0
Set oParentFolder = Nothing
Set oFileSystem = Nothing
Exit Function
End If
sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
sFileName = Dir(sPath & sFileSpec, vbNormal)
Do While sFileName <> ""
iContador = UBound(sFoundFiles, 2)
iContador = iContador + 1
ReDim Preserve sFoundFiles(1 To 2, 1 To iContador)
sFoundFiles(1, iContador) = sPath
sFoundFiles(2, iContador) = sFileName
sFileName = Dir()
Loop
If blIncludeSubFolders Then
For Each oFolder In oParentFolder.SubFolders
ProcurarArquivos oFolder.Path, sFoundFiles, iArqEncontrados,
sFileSpec, blIncludeSubFolders
Next
End If
ProcurarArquivos = UBound(sFoundFiles, 2) > 0
iArqEncontrados = UBound(sFoundFiles, 2)