Toplu resim isim değiştirme

[ykmetiner]

Herkes merhaba ekte ki gibi elimde birçok resim var resimlerin isimlerinin ilk 6 hanesinin kalmasını ve gerisinin silinmesini istiyorum.
Bunu toplu olarak nasıl yapabilirim

Teşekkürler

 

[Korhan Ayhan]

Merhaba,

Benzer isimler denk gelirse dosya isminin ilk 6 karakterine ek _1 yaparak isimlendirir.

Sub ResimAdlariniDuzenle()
    Dim Klasor As String
    Dim Dosya As String
    Dim FSO As Object
    Dim EskiYol As String, YeniYol As String
    Dim DosyaAdi As String, Uzanti As String
    Dim YeniAd As String
    Dim Sayac As Long
    
    ' Klasör seç
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Klasör Seçiniz"
        If .Show = -1 Then
            Klasor = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dosya = Dir(Klasor & "*.*")
    
    Do While Dosya <> ""
    
        Uzanti = LCase(FSO.GetExtensionName(Dosya))
        
        ' Resim filtre
        If Uzanti = "jpg" Or Uzanti = "jpeg" Or Uzanti = "png" _
        Or Uzanti = "bmp" Or Uzanti = "gif" Or Uzanti = "webp" Then
        
            DosyaAdi = FSO.GetBaseName(Dosya)
            
            If Len(DosyaAdi) >= 6 Then
            
                YeniAd = Left(DosyaAdi, 6)
                
                EskiYol = Klasor & Dosya
                YeniYol = Klasor & YeniAd & "." & Uzanti
                
                Sayac = 1
                
                ' Çakışma varsa artır
                Do While FSO.FileExists(YeniYol)
                    YeniYol = Klasor & YeniAd & "_" & Sayac & "." & Uzanti
                    Sayac = Sayac + 1
                Loop
                
                Name EskiYol As YeniYol
                
            End If
        
        End If
        
        Dosya = Dir
    Loop

    MsgBox "Tüm dosyalar başarıyla yeniden adlandırıldı.", vbInformation
End Sub