CONHEÇA o BABOO PRO e a Comunidade BABOO que substituirão o site BABOO e esse fórum

Ir para conteúdo
  • Cadastre-se

Mensagem Recomendada

Pessoal,

Tenho esta macro, que funciona muito bem.

Ela abre um caixa de dialogo, onde eu seleciono um determinada pasta, e ela lista todos os arquivos desta pasta, separando em colunas o endereço e o nome do arquivo, inclusive, as subpastas.

Porém, estou usando ela numa planilha, onde eu nem preciso selecionar uma determinada pasta, pois, a pasta tem o caminho fixo.

Portanto, eu preciso listar os arquivos de uma determinada pasta com caminho fixo.

 

Obrigado.

 

 

Sub exclui_thumbs()
    Dim lLin As Long
    
    Application.ScreenUpdating = False
    
    'Altere o nome da planilha abaixo:
    With Sheets("LISTA")
        For lLin = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
            If .Cells(lLin, "B") = "Thumbs.db" Then .Rows(lLin).Delete
            
            'Desafoga os processos pendentes do Windows a cada 100 linhas iteradas:
            If lLin Mod 100 = 0 Then DoEvents
        Next lLin
    End With

    Application.ScreenUpdating = True
End Sub


Sub ListaArquivos()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
    
    Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        End If
    End With
    msg = "nome e extensão do arquivo procurado;" & vbLf & "os curingas abaixo podem ser utilizados" & _
     vbLf & "              * # ?"
    myExtension = "*"
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    On Error Resume Next
    'Rtn = MsgBox("Incluir sub pastas na pesquisa?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets("LISTA").Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "Nenhum arquivo encontrado"
    End If

  With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With


End Sub

Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
            * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
            * (UCase(myFile.Name) Like UCase(myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function
 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Quer postar a sua dúvida? Cadastre-se pois é rápido e fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar Agora

×
×
  • Criar Novo...