[Resolvido]Alterar nome de arquivo

Boa noite
Preciso de um VBA para alterar arquivos de um diretório C:\ extensão.jpg
Exemplo
123456-022-09.jpg
654321-9080-99.jpg

Preciso que os arquivos sejam alterados para
123456-022.jpg
654321-9089.jpg

Os arquivos não tem mesma qtde de caracteres por isso precisamos que a alteração seja a partir do segundo hífen

Renomear arquivos foi um tema tratado recentemente no fórum.

Veja se o tópico ajuda
https://www.maximoaccess.com/t37816-resolvidorenomear-varios-arquivos-em-funcao-dos-registos-da-tabela

Como sou usuário avançado sem curso de programação entendo que este exemplo irá me ajudar quando tenho um banco de dados interno com tabelas etc
O que desejo é entra num diretório externo ver os arquivos JPG existentes e alterar o nome conforme exemplifiquei
Se puder ajudar agradeço e solicito ao grupo também

Isso remove o segundo hífen e tudo que vier depois dele. Basta apontar a pasta.

Código:

Dim strCaminho As String
   
    'strCaminho = "\\PastaNaRede\"
    strCaminho = "X:\PastaEmDisco\"
   
    '--------------------------------------------------------------------

    Const STR_FORMATO As String = ".jpg"

    Dim strArquivo1 As String
    Dim strArquivo2 As String
    Dim arrArquivo() As String
    Dim intContador As Integer

    ReDim Preserve arrArquivo(0)
    strArquivo1 = Dir(strCaminho & "*" & STR_FORMATO, vbArchive)

    Do While strArquivo1 <> ""
   
        strArquivo2 = Left(strArquivo1, Len(strArquivo1) - Len(STR_FORMATO))
       
        If UBound(Split(strArquivo2, "-")) > 1 Then
            If arrArquivo(0) = "" Then
                arrArquivo(0) = strArquivo2
            Else
                ReDim Preserve arrArquivo(UBound(arrArquivo) + 1)
                arrArquivo(UBound(arrArquivo)) = strArquivo2
            End If
        End If
   
        strArquivo1 = Dir()
   
    Loop
   
    If arrArquivo(0) <> "" Then
        For intContador = 0 To UBound(arrArquivo)
            Name strCaminho & arrArquivo(intContador) & STR_FORMATO _
            As strCaminho & Split(arrArquivo(intContador), "-")(0) & "-" & Split(arrArquivo(intContador), "-")(1) & STR_FORMATO
        Next intContador
    End If
   
    Call MsgBox(intContador & " arquivo(s) renomeados.", vbInformation, "Informação")

O comando esta me parecendo que vai rodar bacana .
Gostaria de um ajuste se for viavel . Estou solicitando pois realmente nao sei como fazer
Acontece o seguinte quando o VBA encontra um arquivo repetido ele para de rodar dizendo a seguinte mensagem : Erro em tempo de execucao 58 - o arquivo ja existe.
Teria como encaixar um comando para sobreescrever o arquivo quando isso acontecer ao inves de parar o comando ?

...

Código:

Dim strCaminho As String
   
    'strCaminho = "\\PastaNaRede\"
    strCaminho = "X:\PastaEmDisco\"
   
    '--------------------------------------------------------------------

    Const STR_FORMATO As String = ".jpg"

    Dim strArquivo1 As String
    Dim strArquivo2 As String
    Dim arrArquivo() As String
    Dim intContador As Integer

    ReDim Preserve arrArquivo(0)
    strArquivo1 = Dir(strCaminho & "*" & STR_FORMATO, vbArchive)

    Do While strArquivo1 <> ""
   
        strArquivo2 = Left(strArquivo1, Len(strArquivo1) - Len(STR_FORMATO))
       
        If UBound(Split(strArquivo2, "-")) > 1 Then
            If arrArquivo(0) = "" Then
                arrArquivo(0) = strArquivo2
            Else
                ReDim Preserve arrArquivo(UBound(arrArquivo) + 1)
                arrArquivo(UBound(arrArquivo)) = strArquivo2
            End If
        End If
   
        strArquivo1 = Dir()
   
    Loop
   
    If arrArquivo(0) <> "" Then
        For intContador = 0 To UBound(arrArquivo)
            strArquivo1 = strCaminho & Split(arrArquivo(intContador), "-")(0) & "-" & Split(arrArquivo(intContador), "-")(1) & STR_FORMATO
            If Dir(strArquivo1, vbArchive) <> "" Then Call Kill(strArquivo1)
            Name strCaminho & arrArquivo(intContador) & STR_FORMATO _
            As strArquivo1
        Next intContador
    End If
   
    Call MsgBox(intContador & " arquivo(s) renomeados.", vbInformation, "Informação")

Meu amigo muito obrigado
Tudo funcionou certinho

O fórum agradece o retorno. Sucesso.

Amigos tenho esse comando que altera o nome de arquivos existentes numa determinada pasta
Acontece que quando o arquivo ja existe ele trava a continuidade do comando
poderia me ajudar a encaixar um comando que sobrescreva o arquivo existente

segue vba

Private Sub Comando0_Click()
Dim myfile As String, newFile As String
Dim myfolder As String

myfolder = "C:\Users\Samsung\Downloads\"

myfile = Dir(myfolder & "*.jpg")
While myfile <> ""
newName = Left(myfile, 7) & ".jpg"
Name myfolder & myfile As myfolder & newName

'code here to copy the fiel to another location
'filecopy myFolder & newName, destFolder & newName
myfile = Dir
Wend

End Sub

Tópico fundido. Mesmo autor, mesmas dúvidas.

Veja, usei a mesma lógica do comando anterior que já foi mostrado e lhe serviu

Private Sub Comando0_Click()
Dim myfile As String, newFile As String
Dim myfolder As String

myfolder = "C:\Users\Samsung\Downloads\"

myfile = Dir(myfolder & "*.jpg")
While myfile <> ""
newName = Left(myfile, 7) & ".jpg"

'se na pasta já houver um arquivo com o nome do novo arquivo então
if dir(myFolder & newName) <> "" then
   'apague esse arquivo que já existe
   call kill(myFolder & newName)
end if

'renomeando o arquivo com a certeza de que não haverá um outro arquivo com o novo nome
Name myfolder & myfile As myfolder & newName

'code here to copy the fiel to another location
'filecopy myFolder & newName, destFolder & newName
myfile = Dir
Wend

End Sub

Concordo bem parecido mas na minha visão de usuário jamais eu conseguiria
Agora já tenho uma base com separadores e também com as funcoes left Right e Mid que nesse segundo exemplo posso trocar quando necessário
Mas sendo sincero eu não conseguiria desvendar essa segunda opção que fez pois apesar de parecida não e igual !
Vou testar e agradeço sua atenção . Depois eu dou como resolvido quando testar !!

Utilizando o codigo apresentado temos um erro abaixo

Erro em tempo de execucao '5'
Argumento ou chamada de procedimento invalida
a depuracao para no myfile = Dir

A parte que eu adicionei não afeta esse trecho do código. Retire a parte do código que eu adicionei e veja se seu novo código funciona com perfeição.

Ou então substitua o seu novo código pelo código que eu criei inicialmente.

Quando eu coloco o meu codigo inicial o erro apresentador é file exists e trava o codigo

Copiando seu codigo ajustado da essa mensagem de erro que mencionei

Nao tenho condicoes de avaliar o que se trata isso infelizmente

Adaptando o código da mensagem número 6

Código:

Dim strCaminho As String
 
    'strCaminho = "\\PastaNaRede\"
    strCaminho = "X:\PastaEmDisco\"
 
    '--------------------------------------------------------------------

    Const STR_FORMATO As String = ".jpg"

    Dim strArquivo1 As String
    Dim strArquivo2 As String
    Dim arrArquivo() As String
    Dim intContador As Integer

    ReDim Preserve arrArquivo(0)
    strArquivo1 = Dir(strCaminho & "*" & STR_FORMATO, vbArchive)

    Do While strArquivo1 <> ""
 
        strArquivo2 = Left(strArquivo1, Len(strArquivo1) - Len(STR_FORMATO))
     
            If arrArquivo(0) = "" Then
                arrArquivo(0) = strArquivo2
            Else
                ReDim Preserve arrArquivo(UBound(arrArquivo) + 1)
                arrArquivo(UBound(arrArquivo)) = strArquivo2
            End If
 
        strArquivo1 = Dir()
 
    Loop
 
    If arrArquivo(0) <> "" Then
        For intContador = 0 To UBound(arrArquivo)
            strArquivo1 = strCaminho & left(arrArquivo(intContador), 7) & STR_FORMATO
            If Dir(strArquivo1, vbArchive) <> "" Then Call Kill(strArquivo1)
            Name strCaminho & arrArquivo(intContador) & STR_FORMATO _
            As strArquivo1
        Next intContador
    End If
 
    Call MsgBox(intContador & " arquivo(s) renomeados.", vbInformation, "Informação")