Como listar todos os arquivos que estão em uma pasta e inserir hyperlinks para eles? Simples! Vamos a solução: Private Sub FS(FoundFiles As Collection, DPath As String, Mask As String, IncludeSubdirectories As Boolean) Dim DirFile As String Dim CollectionItem As Variant Dim SubDirCollection As New Collection 'adiciona barra se não encontrada DPath = Trim(DPath) If Right(DPath, 1) <> "\" Then DPath = DPath & "\" ' procura os arquivos de acordo com a mascara de entrada DirFile = Dir(DPath & Mask) Do While DirFile <> "" FoundFiles.Add DirFile 'adiciona arquivo para a lista DirFile = Dir ' next file Loop ' procura em subdiretórios (vc pode desabilitar estes itens até o LOOP) If Not IncludeSubdirectories Then Exit Sub DirFile = Dir(DPath & "*", vbDirectory) Do While DirFile <> "" 'Adiciona subdiretório If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(DPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add DPath & DirFile DirFile = Dir 'next file Loop ' processamento de subdiretórios For Each CollectionItem In SubDirCollection Call FS(FoundFiles, CStr(CollectionItem), Mask, IncludeSubdirectories) ' Recursive procedure call Next End Sub Sub FS_call() Dim FWhPath As Variant Dim LFWPath As New Collection ' cria a coleção de nomes I = 1 ' preenche a coleção com os arquivos (no exemplo preenche com arquivos do excel 2003 que iniciem com "teste" e tbm nos subtiretórios) Call FS(LFWPath, ActiveWorkbook.Path, "TESTE*.xls", True) ' debug window e valores nas colunas a e b iniciando na linha 1 (I) For Each FWPath In LFWPath ' ciclo de processamento da lista Debug.Print FWPath & Chr(13) Cells(I, 2).Value = FWPath Cells(I, 1).Value = CollectionItem I = I + 1 Next FWPath ' debug window e msgbox de nenhum arquivo encontrado If LFWPath.Count = 0 Then Debug.Print "No file was found !" MsgBox "No file was found !" End If End Sub Sub procv() Range("a:b").ClearContents Call FS_call End Sub |
Pagina Inicial > Excel >