Este fórum foi descontinuado. LEIA AQUI e participe da Comunidade BABOO :)

A área de Remoção de Malwares está aberta na Comunidade BABOO. LEIA AQUI

Ir para conteúdo

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

×
×
  • Criar Novo...