Tomás Vásquez Fórum

Enviado: **Sáb Fev 08, 2020 11:53 pm**

Pessoal, esse código retirei do site "Guiadoexcel", mas tentando tirar uma dúvida eles me informaram que não possuem mais fórum, então..
Quero renomear os arquivos da pasta Temp. Acontece que quero que os nomes originais permaneçam e seja acrescentado apenas o texto "ordem 0 -" nates do nome existente.
Suponha que o nome de dois arquivos dessa pasta seja "Carta Cobrança.pdf" e "Ofício.pdf"
o código deverá renomear como: "Ordem 01 - Carta Cobrnança.pdf" e Ordem 02 - Ofício.pdf"

segue o código:

Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Dim NomeAntigo As String

Dim MyFolder, MyFile, NewName As String, i As Integer
MyFolder = "c:\TEMP"
MyFile = Dir(MyFolder & "*.*")

Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")

'Chama a fun??o para renomear os arquivos
lsRenomearArquivos Caminho, NomeBase, NomeAntigo
End Sub
'Fun??o que renomea os arquivos
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String, NomeAntigo As String)

Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String

Set FSO = CreateObject("Scripting.FileSystemObject")

If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' n?o existe.", vbCritical, "Erro"
Exit Sub
End If

lSeq = 1

Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files

Cells(1, 1) = "De"
Cells(1, 2) = "Para"

Linha = 2

For Each Arquivo In Arquivos
i = InStr(1, MyFile, ".", 1)
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & "-" & NomeAntigo & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome

Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1

Next
End Sub

Enviado: **Dom Fev 09, 2020 9:30 am**

Não sei se entendi, mas substitua suas rotinas pela abaixo,
experimente e veja se atende.

Código: Selecionar todos

Option Explicit
'Seleciona os arquivos
Public Sub lsSelecionaArquivo()
Dim MyFolder As String
'Defina/informe a pasta e hd a ser utilizado
MyFolder = "c:\TEMP"

'Chama a função para renomear os arquivos
lsRenomearArquivos MyFolder, "Z", "Z"
End Sub
 'Rotina que renomeia os arquivos
Public Sub lsRenomearArquivos(ByVal Caminho As String, ByVal NomeBase As String, ByVal NomeAntigo As String)
 
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String

Set FSO = CreateObject("Scripting.FileSystemObject")

If Not FSO.FolderExists(Caminho) Then
    MsgBox "A pasta &#39;" & Caminho & "&#39; não existe.", vbCritical, "Erro"
    Exit Sub
End If

lSeq = 1

Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files

Cells(1, 1) = "De"
Cells(1, 2) = "Para"

Linha = 2

For Each Arquivo In Arquivos
    'Definição/formação do nome do arquivo existente/localizado
    If NomeAntigo = "Z" Then NomeAntigo = Mid(Arquivo, Len(Caminho) + 2, Len(Arquivo) - 4 - Len(Caminho) - 1)
    'Inclui na coluna "A" o nome e caminho do arquivo localizado
    Cells(Linha, 1) = UCase$(Arquivo.Path)
    'Definição/formação do novo nome do arquivo
    lNovoNome = Caminho & "\" & Format(lSeq, "00") & "-" & NomeAntigo & Right(Arquivo, 4)
    'Renomeia o arquivo localizado
    Name Arquivo.Path As lNovoNome
    'Inclui na coluna "B" o nome e caminho do arquivo renomeado
    Cells(Linha, 2) = lNovoNome
    'Redefine a variavel
    NomeAntigo = "Z"
    'Incrementa a numeração
    lSeq = lSeq + 1
    'Incrementa a linha da celula
    Linha = Linha + 1
Next
End Sub

Enviado: **Seg Fev 10, 2020 2:47 pm**

Perfeito Reinaldo. Muito obrigado meu amigo.
Caso possa dar uma ajuda na minha outra dúvida intitulada "Busca Avançada" eu agradeceria

Enviado: **Qui Mar 12, 2020 8:10 am**

Reinaldo, mais uma vez com esse problema, Gostaria que esse código vasculhasse todas as pastas dentro do diretório Temp e renomeasse os arquivos de todas conforme está fazendo, ou seja, quero que fça o que faz só que em todas as pastas que encontrar dento do diretório determinado,

Ainda, já vi em algum lugar como colocar essa palavra RESOLVIDO antes dos temas, mas não sei mais como fazer, Agradeço a dica.

Obrigado

Enviado: **Qui Mar 12, 2020 10:37 am**

"...em todas as pastas que encontrar dento do diretório determinado..."
Talvez algo +/-

Código: Selecionar todos

Public Sub lsSelecionaArquivo()
Dim MyFolder As String
Dim Fso As Object
Dim f As Folder, sf As Folder

'Defina/informe a pasta e hd a ser utilizado
MyFolder = "c:\TEMP"
'Chama a função para renomear os arquivos diretorio inicial
lsRenomearArquivos MyFolder, "Z", "Z"

'Chama a função para renomear os arquivos de cada subdiretorio encontrado
Set Fso = CreateObject("Scripting.FileSystemObject")
Set f = Fso.GetFolder(MyFolder)
For Each sf In f.SubFolders
Debug.Print sf.path
lsRenomearArquivos sf.path, "Z", "Z"
Next
End Sub

Enviado: **Qui Mar 19, 2020 3:41 pm**

Reinaldo, apresentou o seguinte erro na variável f:

Enviado: **Qui Mai 14, 2020 3:23 pm**

Ok. Resolvido. Agora eu quero retirar apenas a primeira letra de todos os nomes de arquivos anteriores e só depois fazer a renomeaçao

Tomás Vásquez Fórum

Renomear Arquivos conservando nomes

Renomear Arquivos conservando nomes

Re: Renomear Arquivos conservando nomes

[RESOLVIDO]Renomear Arquivos conservando nomes

Re: Renomear Arquivos conservando nomes

Re: Renomear Arquivos conservando nomes

Re: Renomear Arquivos conservando nomes

Re: Renomear Arquivos conservando nomes