Ir para conteúdo
Fórum Script Brasil
  • 0

Renomear vários arquivos com VBA


Gê Reiz

Pergunta

Bom dia.

Desenvolvi um código para renomear aquivos pdf de uma pasta através do VBA. o Código abre o arquivo (NF), extrai o nome do cliente na nota, fecha o arquivo e renomeia com o nome do cliente. Porém gostaria de fazer através de um laço que pegasse todos os arquivos da pasta e fizesse o mesmo, mas só consegui fazer em um arquivo indicando o caminho dele.

Agradeço qualquer ajuda, e segue o código abaixo:



Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Dim AdobeFile As String

Sub Copiar_Dados_PDF_Start()

Dim AdobeApp As String
Dim StartAdobe

    
    
    AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
    AdobeFile = ThisWorkbook.Path & "\NF\Damires - NF.pdf"
     
  
    StartAdobe = Shell("" & AdobeApp & " " & """" & AdobeFile & """" & "", 1)
    
    AdobeFile = VBA.Replace(VBA.Right(AdobeFile, VBA.Len(AdobeFile) - VBA.InStrRev(AdobeFile, "\")), ".pdf", "")
    
    Application.OnTime Now + TimeValue("00:00:03"), "FirstStep"
    
End Sub


Private Sub FirstStep()
    SendKeys ("^a")
    SendKeys ("^c")
    Application.OnTime Now + TimeValue("00:00:02"), "SecondStep"
    
End Sub


Private Sub SecondStep()
Dim ws As Worksheet
Dim i!

    
    On Error Resume Next
     AppActivate Application.Caption
    On Error GoTo 0
  
   With ThisWorkbook
   .Activate
    For i = 1 To .Worksheets.Count
    If .Sheets(i).Name = "..." Then
    .Sheets(i).Activate
    .Sheets(i).Cells.Clear
     Exit For
    End If
     Next
    End With
    
    Sheets("...").Range("A1").Activate
    SendKeys ("^v")
    Sleep 1000
    SendKeys ("{RIGHT}")

    Application.OnTime Now + TimeValue("00:00:02"), "fechapdf"
    
    
End Sub


Private Sub fechapdf()

Dim KillPdf As String

KillPdf = "TASKKILL /F /IM AcroRd32.exe"
Shell KillPdf, vbHide

Application.OnTime Now + TimeValue("00:00:02"), "extrairRazao"

End Sub


Private Sub extrairRazao()

Dim Razao As String


Razao = Sheets("...").Range("A17").Value
pontos = InStr(1, Razao, ":")
qtdeLetras = Len(Razao)
nome = Right(Razao, qtdeLetras - pontos)
Sheets("...").Range("E5").Value = nome

' MsgBox nome

Application.OnTime Now + TimeValue("00:00:02"), "renomeaPfd"

End Sub


Private Sub renomeaPfd()

Name "C:\Users\Georgie\Documents\ENVIO DE EMAILS\NF\Damires - NF.pdf" As "C:\Users\Georgie\Documents\ENVIO DE EMAILS\NF\" & Sheets("...").Range("E5").Value & " - NF.pdf"


End Sub
Link para o comentário
Compartilhar em outros sites

5 respostass a esta questão

Posts Recomendados

  • 0

Olha se te ajuda:

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 ListaArquivos()
    Dim arquivos() As String
    Dim lCtr As Long
    arquivos = ListaArquivos("C:\temp")
    For lCtr = 0 To UBound(arquivos)
      Debug.Print arquivos(lCtr)
'Seu comando aqui...
    Next
End Sub

 

Link para o comentário
Compartilhar em outros sites

Participe da discussão

Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.

Visitante
Responder esta pergunta...

×   Você colou conteúdo com formatação.   Remover formatação

  Apenas 75 emoticons são permitidos.

×   Seu link foi incorporado automaticamente.   Exibir como um link em vez disso

×   Seu conteúdo anterior foi restaurado.   Limpar Editor

×   Você não pode colar imagens diretamente. Carregar ou inserir imagens do URL.



  • Estatísticas dos Fóruns

    • Tópicos
      152k
    • Posts
      651,7k
×
×
  • Criar Novo...