Dosya özellikleri listeleme

[mf.murat]

Arkadaşlar site içerisinde araştırmalarım sonucunda aşağıdaki kodlar ile bir klasör içerisindeki dosyalara ait özellikleri aşağıda verilen kodlar ile listeleyebiliyoruz.

Aşağıdaki kodlar dosyaları yan yana ayrı sutunlarda listelemektedir.
Bu kodlar ile klasör seçtiğimde içerisindeki dosya özelliklerini Ek'teki Excel de belirtiğim üzere alt alta satırlar halinde nasıl sıralayabilirim.

Sub dosyaozellikleri()
On Error Resume Next
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
klasoryolu = klasor.Items.Item.Path
If klasoryolu = "" Then Exit Sub
For Each dosyaadi In CreateObject("Scripting.FileSystemObject").GetFolder(klasoryolu).Files
c = c + 1
Set dosya = CreateObject("Shell.Application").Namespace(klasor).ParseName(dosyaadi.Name)
Cells(1, c + 1) = dosyaadi.Name
For a = 1 To 40
If c = 1 Then Cells(a + 1, "a") = CreateObject("Shell.Application").Namespace(klasor).GetDetailsOf("", a)
Cells(a + 1, c + 1) = CreateObject("Shell.Application").Namespace(klasor).GetDetailsOf(dosya, a)
Next
Next
End Sub

Kodu yazan Levent Menteşoğlu arkadaşımıza teşekkür ederim.Emeğine sağlık.

 

[halit3]

bunu denermisiniz.

Sub dosyaozellikleri()
sat = 1
Cells.Hyperlinks.Delete
On Error Resume Next
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
klasoryolu = Klasor.Items.Item.Path
If klasoryolu = "" Then Exit Sub
Cells(1, 1) = "Dosya adı"
For a = 1 To 48
Cells(1, a + 1) = CreateObject("Shell.Application").Namespace(Klasor).GetDetailsOf("", a)
Next
sat = sat + 1
For Each dosyaadi In CreateObject("Scripting.FileSystemObject").GetFolder(klasoryolu).Files
c = c + 1
Set Dosya = CreateObject("Shell.Application").Namespace(Klasor).ParseName(dosyaadi.Name)
Cells(sat, 1) = dosyaadi.Name
Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Klasor & "\" & dosyaadi.Name, TextToDisplay:=dosyaadi.Name
For a = 1 To 48
Cells(sat, a + 1) = CreateObject("Shell.Application").Namespace(Klasor).GetDetailsOf(Dosya, a)
Next
sat = sat + 1
Next
MsgBox "işlem tamam"
End Sub

Sub dosyaozellikleri()
Columns("A:B").Interior.ColorIndex = xlNone
Columns("A:B").ClearContents
sat = 2
On Error Resume Next
Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
klasoryolu = klasor.Items.Item.Path
If klasoryolu = "" Then Exit Sub
For Each dosyaadi In CreateObject("Scripting.FileSystemObject").GetFolder (klasoryolu).Files
c = c + 1
Set dosya = CreateObject("Shell.Application").Namespace(klasor).ParseName(dosyaadi.Name)
Cells(sat, 1) = dosyaadi.Name
Cells(sat, 1).Interior.ColorIndex = 8
sat = sat + 1
For a = 1 To 47
Cells(sat, "a") = CreateObject("Shell.Application").Namespace(klasor).GetDetailsOf("", a)
Cells(sat, "b") = CreateObject("Shell.Application").Namespace(klasor).GetDetailsOf(dosya, a)
sat = sat + 1
Next
Next
MsgBox "işlem tamam"
End Sub

 

[mf.murat]

Hata

Aşağıda yazığım satırda hata veriyor.

For Each dosyaadi In CreateObject("Scripting.FileSystemObject").GetFold er(klasoryolu).Files

 

[halit3]

buradaki GetFold er boşluğu al yani birleştir
GetFolder

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub DOSYA_ÖZELLİKLERİ()
    Dim Klasör As Object, Klasör_Yolu As String, Dosya As Object, Satır As Long, X As Integer
        
    On Error Resume Next
    
    Application.ScreenUpdating = False
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
    Klasör_Yolu = Klasör.Items.Item.Path
    If Klasör_Yolu = "" Then Exit Sub
    Cells.ClearContents
    Range("A1") = "Dosya Adı"
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasör_Yolu).Files
        Satır = Satır + 1
        Set Dosya = CreateObject("Shell.Application").Namespace(Klasör).ParseName(Dosya.Name)
        Cells(Satır + 1, "A") = Dosya.Name
        Cells(Satır + 1, "A").Hyperlinks.Add Anchor:=Cells(Satır + 1, "A"), Address:=Dosya.Path, TextToDisplay:=Dosya.Name
        
        For X = 1 To 40
            Cells(1, X + 1) = CreateObject("Shell.Application").Namespace(Klasör).GetDetailsOf("", X)
            Cells(Satır + 1, X + 1) = CreateObject("Shell.Application").Namespace(Klasör).GetDetailsOf(Dosya, X)
        Next
    Next
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mf.murat]

Arkadaşlar Çok Teşekkür ederim.
Dosyam çalıştı.
Excel web yöneticileri ve sizin gibi paylaşım sever tüm arkadaşlara teşekkür ederim...

 

[halit3]

Arkadaşlar Çok Teşekkür ederim.
Dosyam çalıştı.
Excel web yöneticileri ve sizin gibi paylaşım sever tüm arkadaşlara teşekkür ederim...

iyi akşamlar

Private Sub CommandButton1_Click()
sat = 1
Cells.Hyperlinks.Delete
On Error Resume Next
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
klasoryolu = Klasor.Items.Item.Path
If klasoryolu = "" Then Exit Sub
Cells(1, 1) = "Dosya adı"
For a = 1 To 48
Cells(1, a + 1) = CreateObject("Shell.Application").Namespace(Klasor).GetDetailsOf("", a)
Next
sat = sat + 1
For Each dosyaadi In CreateObject("Scripting.FileSystemObject").GetFolder(klasoryolu).Files
c = c + 1
Set Dosya = CreateObject("Shell.Application").Namespace(Klasor).ParseName(dosyaadi.Name)
Cells(sat, 1) = dosyaadi.Name
Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Klasor & "\" & dosyaadi.Name, TextToDisplay:=dosyaadi.Name
For a = 1 To 48
Cells(sat, a + 1) = CreateObject("Shell.Application").Namespace(Klasor).GetDetailsOf(Dosya, a)
Next
sat = sat + 1
Next
MsgBox "işlem tamam"
End Sub

 

[mf.murat]

Link VErme

Arkadaşlar ilginiz için teşekkür ederim.
Bu listelediğim dosyalara link vermemde mümkünmüdür?

 

[Korhan Ayhan]

Selamlar,

#5 nolu mesajımdaki kodu güncelledim. Denermisiniz.

 

[mf.murat]

Teşekkür ederim.Çalışıyor.Emeğinize sağlık...

 

[OZDO2]

alt klasör içindeki dosyaları

Seçtiğimiz klasörde dosya varsa dosyayı görüyor fakat bir alt klasördeki dosyaları da gösterebilirsek çok güzel olacağını düşünüyorum bir inceleyebilir misiniz? Eğer ben beceremedi isem kusura kalmayın.

 

[halit3]

Seçtiğimiz klasörde dosya varsa dosyayı görüyor fakat bir alt klasördeki dosyaları da gösterebilirsek çok güzel olacağını düşünüyorum bir inceleyebilir misiniz? Eğer ben beceremedi isem kusura kalmayın.

burada bir sürü örnek var buda başkası olsun

Dim Klasor As Object
Dim Kaynak As String
Sub dosyaListele()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
Cells.Hyperlinks.Delete
Cells(1, 1) = "Dosya adı"
For a = 1 To 48
Cells(1, a + 1) = CreateObject("Shell.Application").Namespace(Klasor).GetDetailsOf("", a)
Next
Call Listele(Kaynak, "")
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
End Sub
Private Sub Listele(Klasor As String, Uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String, sat As Long, a As Long, Dosya1 As Object
Set Hedef = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).subfolders
Dim wb As Workbook
Uzanti = baslangıc
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = Cells(Rows.Count, "A").End(3).Row + 1
'Cells(sat, 1) = Dosya
Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Klasor & "\" & Dosya, TextToDisplay:=Dosya
Set Dosya1 = CreateObject("Shell.Application").Namespace(Klasor & "\").ParseName(Dosya)
For a = 1 To 48
Cells(sat, a + 1) = CreateObject("Shell.Application").Namespace(Klasor & "\").GetDetailsOf(Dosya1, a)
Next
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call Listele(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub

Bunuda bu siteden almıştım ve birazcık değiştirmiştim.

Public sat As Long
Sub dosyaListele()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"
AltListe (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Private Sub AltListe(yol As String)
Dim klsrAra, klsrLst As Object, Dosya
Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Dosya = Dir(yol & "\*.*")
While Dosya <> ""
DoEvents
sat = [a65000].End(3).Row + 1
Cells(sat, 1) = yol
Cells(sat, 2) = Dosya
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(yol & "\" & Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & sat), Address:=yol & "\" & Dosya
Range("C" & sat) = .Type
Range("D" & sat) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & sat) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & sat) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & sat) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & sat) = Format(.DateLastModified, "hh:mm:ss")
End With
Dosya = Dir
Wend
On Error GoTo sonraki
For Each klsrAra In klsrLst
Call AltListe(klsrAra.Path)
sonraki:
Next
End Sub

 

[OZDO2]

Ellerine sağlık güzel olmuş. Bunlarla azda olsa işimi görebilirim sanırım. İncelemelerim sonucu
birinci makro listeleme yaparken 2. makroya göre ağır fakat listeleme güzel
ikinci makro ise hızlı listeleme eksik

bende film arşivi olduğu için süre, çözünürlük, bit değeri, veri değeri olsun bu tarz verileri listelemek istiyorum. Eğer 2. makroya bu üstteki özellikleri ekleye bilmen mümkünse çok sevinirim açıkçası olmazsa canın sağ olsun ben 2 sinide çalıştırır 3. sayfada birleştiririm. Hiç problem değil.

 

[wirrrus]

Merhaba,

Değişken bir klasör yerine sabit bir klasör kullanıyorum. Klasörü seçmek yerine nasıl sabit olarak belirlerim?

bu satır yerine ne yazmalıyım?
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)

teşekkürler...

Selamlar,

Aşağıdaki kodu denermisiniz.

Merhaba,

Değişken bir klasör yerine sabir bir klasör kullanıyorum. Klasörü seçmek yerine nasıl sabit olara belirlerim?

bu satır yerine ne yazmalıyım?
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)

teşekkürler...

 

[Korhan Ayhan]

Alttaki satırı komple siliniz.

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)

Alttaki satırı ise;

Klasör_Yolu = Klasör.Items.Item.Path

Bununla değiştirin.

Klasör_Yolu = "C:\Deneme"