Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Renomear Arquivos conservando nomes

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Renomear Arquivos conservando nomes

Mensagem por Adonias »

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
Anexos
RenomearArquivos.zip
(17.46 KiB) Baixado 186 vezes


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Renomear Arquivos conservando nomes

Mensagem por Reinaldo »

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

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 '" & 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
    '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


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

[RESOLVIDO]Renomear Arquivos conservando nomes

Mensagem por Adonias »

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


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias »

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


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Renomear Arquivos conservando nomes

Mensagem por Reinaldo »

"...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


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias »

Reinaldo, apresentou o seguinte erro na variável f:
Anexos
Tela erro
Tela erro
Screenshot_20200319_154023.jpg (96.64 KiB) Exibido 6063 vezes


Adonias
Manda bem
Manda bem
Mensagens: 167
Registrado em: Sáb Jun 02, 2012 12:55 pm

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias »

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


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder