0

Bom dia a todos. Adaptei um código para renomear vários arquivo com vba, que realiza a seguinte função:

  1. Eu seleiono a pasta,

  2. O VBA abre o PDF (Nota fiscal) , extrai a informação do texto e com a razão social fecha o pdf e renomeia ele com o nome extraido.

O problema é que após renomear o primeiro arquivo corretamente a execução do código trava, e é necessário finalizar o processo.

Segue abaixo o código.

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Public Function ListaArquivos(ByVal Caminho As String) As String()
    

    'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime
    Dim FSO As New FileSystemObject
    Dim result() As String
    Dim Pasta As Folder
    Dim Arquivo As File
    Dim Indice As Long
 
 
    ReDim result(0) As String
    If FSO.FolderExists(Caminho) Then
        Set Pasta = FSO.GetFolder(Caminho)
 
        For Each Arquivo In Pasta.Files
            Indice = IIf(result(0) = "", 0, Indice + 1)
            ReDim Preserve result(Indice) As String
            result(Indice) = Arquivo.Name
        Next
    End If
 
    ListaArquivos = result
ErrHandler:
    Set FSO = Nothing
    Set Pasta = Nothing
    Set Arquivo = Nothing
End Function

Private Sub selecionar_pasta()
 Dim box As Folder
 Dim arquivos() As String
 Dim lCtr As Long
 Dim AdobeApp As String
 Dim StartAdobe
 Dim Arquivo As String
 Dim NomeAntigo As String
 Dim NomeNovo As String

 
     On Error Resume Next
     linha = 1
     ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Buscar pasta"
            .InitialFileName = ThisWorkbook.Path
            .Show
            .AllowMultiSelect = False
            Pasta = .SelectedItems(1)
        End With
   
    TextBox1 = box
    

    arquivos = ListaArquivos(Pasta)
    Sleep 1000
    For lCtr = 0 To UBound(arquivos)
      Debug.Print arquivos(lCtr)
        'Inserir código aqui'
        
        'Cells(linha, 1).Value = arquivos(lCtr)
        'linha = (linha + 1)
        'Sleep 500
        
            
          pdf = arquivos(lCtr)
        
          AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
          
          Sleep 2000
          
          
        
          For Each pdf In Pasta
          
          
          Adobefile = Pasta & "\" & pdf
        
          StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1)
         
        
          Sleep 2000
              
            
            Application.SendKeys ("^a")

            Application.SendKeys ("^c")
             Sleep 2000

           
           
           Dim KillPdf As String

           KillPdf = "TASKKILL /F /IM AcroRd32.exe"
           Shell KillPdf, vbHide
           
                      
           AppActivate Application.Caption
        
        
            
            Sheets("teste").Range("A1").Activate
            SendKeys ("^v")
                     
            DoEvents
                
            
            
            
            Dim Razao As String


            Razao = Sheets("teste").Range("A17").Value
            pontos = InStr(1, Razao, ":")
            qtdeLetras = Len(Razao)
            Nome = Right(Razao, qtdeLetras - pontos)
            Sheets("teste").Range("C1").Value = Nome
            
            
            
            
              Do While Not IsEmpty(Range("C1"))
              
             
                NomeAntigo = Pasta & "\" & pdf
                    
                NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
                
                Sheets("teste").Range("C2").Value = Adobefile
                    
                Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
                    

                
                Name NomeAntigo As NomeNovo
                
                
               
               ' DoEvents
                
        
              Loop
    
   
   
         ' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído"
            
            
        
            Next
        
        
    Next
    
     ' MsgBox ("Arquivos Encontrados = ") & (linha - 1)
     
     
      

End Sub

Já tentei de tudo, e não consegui resolver esse problema, se eu remover o Do while, ele executa normalmente, porem não renomeia os arquivos. Seu eu faço esse laço, ele renomeia só o primeiro e trava geral.



Qualquer esclarecimento, agradeço.

1 Resposta 1

0

Você criou um loop infinito em:

Do While Not IsEmpty(Range("C1"))

O laço sempre continuará executando pois o range C1 não está vazio, uma vez que ele foi preenchido algumas linhas antes em:

Sheets("teste").Range("C1").Value = Nome

Altere seu código para adicionar uma condição válida para saída do loop ou use outra alternativa ao aderente à sua lógica.

Por exemplo, usar um IF no lugar do DO WHILE:

If Not IsEmpty(Range("C1")) Then

    NomeAntigo = Pasta & "\" & pdf
    
    NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
    
    Sheets("teste").Range("C2").Value = Adobefile
    
    Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
    
    Name NomeAntigo As NomeNovo
    
    ' DoEvents

End If
5
  • Obrigado pela ajuda phduarte, ao alterar o loop, o código executa completamente, porém como informei ele renomeia somente o primeiro arquivo e não os demais
    – gereiz
    13/01/2021 às 17:36
  • Você selecionou uma pasta ou arquivos específicos dentro da pasta?
    – phduarte
    13/01/2021 às 17:41
  • Seleciono a pasta, e todos os arquivos são abertos um a um normalmente
    – gereiz
    13/01/2021 às 18:07
  • phduarte, muito obrigado pela ajuda, resolvi usando o If e adicionando um Sleep de 1s antes de renomear os arquivos. O Script executava muito rápido e por isso não renomeava.
    – gereiz
    13/01/2021 às 19:09
  • Muito bom! Considere escolher essa resposta como conclusiva marcando à como aceita, assim essa questão sairá da lista de pendentes. Abraços
    – phduarte
    13/01/2021 às 20:56

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .