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

 

[muratgunay48]

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

Hocam emeğinize sağlık. Mükemmel bir çalışma. Ben hep elle yapıyordum. Sağ olun var olun. Ben izninizle Right olarak kullanırım.
Yalnız hocam şöyle biz WhatsApp üzerinden gelen fotoğrafları çok kaydediyoruz.
Fotoğraf WhatsApp Image 2026-03-20 at 18.01.32 şeklinde isimlendiriliyor. Hiç değişmiyor. Yazdığınız kodu soldan 16'dan 26'ya kadar şeklinde kaydet diye nasıl revize edebiliriz. Hatta affınıza sığınarak. 2026-03-20 şeklinde olan ismi 2026.03.20 şeklinde değiştirse. Çünkü o şekilde arşivliyoruz.
Tekrar teşekkür ederim.
Saygılarımla.

 

[alicimri]

Sn. @Korhan Ayhan nın kodlarındaki

 YeniAd = Left(DosyaAdi, 6)

Satırını aşağıdaki gibi değiştirn.

YeniAd =Replace(Mid(DosyaAdi, 16, 10), "-", ".")

 

[muratgunay48]

Sn. @Korhan Ayhan nın kodlarındaki

 YeniAd = Left(DosyaAdi, 6)

Satırını aşağıdaki gibi değiştirn.

YeniAd =Replace(Mid(DosyaAdi, 16, 10), "-", ".")

Çok teşekkür ederim hocam.