Jump to content
Fórum Script Brasil
  • 0

Renomear vários arquivos com VBA


Gê Reiz

Question

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 to post
Share on other sites

5 answers to this question

Recommended Posts

  • 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 to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



  • Forum Statistics

    • Total Topics
      149193
    • Total Posts
      645448
×
×
  • Create New...