Bilgisayardaki müzik dosyalarını tek klasöre toplamak

[unur]

Excel formunda sorulabilecek en son sorulardan biri,
Konunun Excel kitabı yada sayfasıyla alakası yok ama böyle bir şey yapılabilirmi?

Bilgisayardaki müzikleri genelde tek klasör altında toplarım ancak.Çocuklar zaman zaman kendi adlarına klasörler oluştuyorlar ve farklı farklı klasörlere müzik dosyalarını kopyalıyorlar.Buda bilgisayarda hafızayı gereksiz yere doldurmuş oluyor.Geçen gün bir arama yaptım aynı müzik dosyasından 3-4 tane olan bile var.

Burada yapmak istediğim makro aracılığıyla c ve d dizinlerinde müzik dosyalarını bulup mükererer olanları silip geri kalanları tek klasörde toplayabilirmiyim?

Teşekkürler.

 

[Mahir64]

Merhaba
Maro ile yapılabilirmi bilmiyorum ama;

Arama işlevini kullanarak,
*.mp3, *.wav gibi arama yapın.
Arama sonuçları listelendiğinde bir klasör oluşturun ve arama sonuçlarını Ctrl A ile seçin kopyalayın ve oluşturduğunuz klasöre yapıştırın.
Birden fazla olan kayıtlarda değiştirme uyarısı verecektir.
Evet diyerek Teke düşürebilirsiniz.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu kullanabilirsiniz.

Windows 7 işletim sisteminde "C" klasöründe hata veriyor. Sanıyorum hatayı gizli klasörlerden dolayı veriyor. Bir çözümü varmıdır bilemiyorum. Fakat "D" klasöründeki müzik dosyalarını sorunsuzca aktardı.

"mp3" - "wma" - "wav" dosyalarını aktarmaktadır. Değişik uzantılar kod içine adapte edilebilir.

Müzik dosyalarınız masaüstünde oluşturulan "Yeni_Müzikler" adlı klasöre aktarılmaktadır.

Kod çalıştığında sizden müzik dosyalarınızın olduğu klasörü ya da sürücüyü seçmenizi isteyecek seçiminize göre aktarım işlemini yapacaktır.

Option Explicit

Dim Dosya_Sistemi As Object, Yeni_Dosya_Yolu As String
Dim Uzantı As String, Dosya As String
Dim Klasör As Object, Alt_Klasör As Object, Alt_Dosya As Object
 
Sub Tüm_Müzik_Dosyalarını_Tek_Klasöre_Aktar()
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    
    Yeni_Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders(10) & "\Yeni_Müzikler"
    
    If Not Dosya_Sistemi.FolderExists(Yeni_Dosya_Yolu) Then
        Dosya_Sistemi.CreateFolder (Yeni_Dosya_Yolu)
    End If
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)

    Set Klasör = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Private Sub Liste(Yol As String)
    On Error Resume Next
    Dosya = Dir(Yol & "\")
    
    While Dosya <> ""
        DoEvents
        Uzantı = Dosya_Sistemi.GetExtensionName(Dosya)
        If Uzantı = "mp3" Or Uzantı = "wma" Or Uzantı = "wav" Then
            If Not Dosya_Sistemi.FileExists(Yeni_Dosya_Yolu & "\" & Dosya) Then
                Dosya_Sistemi.CopyFile Yol & "\" & Dosya, Yeni_Dosya_Yolu & "\"
                Dosya_Sistemi.DeleteFile Yol & "\" & Dosya, True
            Else
                Dosya_Sistemi.DeleteFile Yol & "\" & Dosya, True
            End If
        End If
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasör = Dosya_Sistemi.GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
        Dosya = Dir(Alt_Dosya.Path & "\")
        
        While Dosya <> ""
            DoEvents
            Uzantı = Dosya_Sistemi.GetExtensionName(Dosya)
            If Uzantı = "mp3" Or Uzantı = "wma" Or Uzantı = "wav" Then
                If Not Dosya_Sistemi.FileExists(Yeni_Dosya_Yolu & "\" & Dosya) Then
                    Dosya_Sistemi.CopyFile Alt_Dosya.Path & "\" & Dosya, Yeni_Dosya_Yolu & "\"
                    Dosya_Sistemi.DeleteFile Alt_Dosya.Path & "\" & Dosya, True
                Else
                    Dosya_Sistemi.DeleteFile Alt_Dosya.Path & "\" & Dosya, True
                End If
            End If
            Dosya = Dir
        Wend
    
    Alt_Liste (Alt_Dosya.Path)
 
Devam:
    Next

    Set Alt_Klasör = Nothing
End Sub