ATENÇÃO NOVOS USUÁRIOS

Se registrou recentemente? Seu cadastro será avaliado e mendiante aprovação, a conta será ativada e você poderá usufruir do fórum. O tempo de avaliação gira em torno de 24 a 48 horas.

Esqueceu sua senha?

Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

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: 155
Registrado em: Sáb Jun 02, 2012 12:55 pm

Renomear Arquivos conservando nomes

Mensagem por Adonias » 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
Anexos
RenomearArquivos.zip
(17.46 KiB) Baixado 79 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: 1414
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Renomear Arquivos conservando nomes

Mensagem por Reinaldo » Dom Fev 09, 2020 9:30 am

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


Reinaldo
:oops: :D :mrgreen: :geek:

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

[RESOLVIDO]Renomear Arquivos conservando nomes

Mensagem por Adonias » 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



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

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias » 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



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: 1414
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Renomear Arquivos conservando nomes

Mensagem por Reinaldo » 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


Reinaldo
:oops: :D :mrgreen: :geek:

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

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias » Qui Mar 19, 2020 3:41 pm

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



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

Re: Renomear Arquivos conservando nomes

Mensagem por Adonias » 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



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