Listar todos os arquivos de um diretório

Objetivo: Demonstrar o uso do VBA para listar todos o arquivos de determinada extensão a partir de um diretório determinado.

São utilizadas para isso várias técnicas interessantes como selecionar pastas, solicitar entradas de dados a partir de uma caixa de mensagem, como criar e utilizar um vetor redimensionado dinamicamente.

Esta planilha busca todos os arquivos de um determinado diretório a partir de uma busca rápida. Para tanto você clica no botão, especifica o tipo de arquivo que será buscado, exemplo *.xlsm ou *.xls, *.xlsm digitando junto e separado com vírgula e depois determinando o diretório aonde serão identificados os arquivos.

Há no código fonte programações desnecessárias, como é o caso do vetor dinâmico, mas ele está ali para servir de exemplo e pesquisa.

Abaixo o código fonte da planilha.

Public Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
    As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type


Sub ListarArquivosExcel()
    Dim FName As String
    'Cria um vetor de strings
    Dim arNames() As String
    Dim myCount As Integer
    Dim fPasta As String
    Dim lsExtensao As String

    lsExtensao = "*.*"

    'Camihho do arquivo
    lsExtensao = InputBox("Digite o tipo de arquivo procurado, " & vbcr13 & " exemplo *.xls ou *.* para Excel ou para todos:", "Extensão do arquivo...", ActName)

    'Seleciona a pasta
    fPasta = gfSelecionarPasta("C:", "Selecione o local aonde será gravado o arquivo:")

    'Determina o diretório e a extensão do arquivo
    FName = Dir(fPasta & lsExtensao)

    'Limpa a planilha
    Sheets("Plan1").Range("A:XFD").Clear

    'Enquanto FName for igual a vazio "", realiza a listagem dos arquivos
    Do Until FName = ""
        myCount = myCount + 1
        'Redimensiona o vetor, preservando os dados
        ReDim Preserve arNames(1 To myCount)
        arNames(myCount) = FName
        'Passa os dados para a planilha
        Cells(myCount, 1).Value = arNames(myCount)
        'Atualiza a variável FName
        FName = Dir
    Loop
End Sub

Public Function gfSelecionarPasta(ByVal vFolder As String, Optional Title As String, Optional hWnd) As String

    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String

    folder = String$(255, Chr$(0))

    With bi
        If IsNumeric(hWnd) Then .hOwner = hWnd
        .pidlRoot = 0
        If Title  "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "Select a Folder" & Chr$(0)
        End If
    End With

    pidl = SHBrowseForFolder(bi)

    If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
        folder = Left(folder, InStr(folder, Chr$(0)) - 1)
    Else
        folder = ""
    End If

    If Right(folder, 1)  "\" And Len(folder) > 0 Then folder = folder & "\"

    gfSelecionarPasta = folder

End Function

Abraço

Marcos Rieper