• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Klasör içini listeleme (ek özellik) ?

G

Gorarr

Katılım
31 Ağustos 2010
Mesajlar
387
Excel Vers. ve Dili
Excel 2007-2010 Eng
Open Office Trk
Selamlar, forumda bulduğum bir dosya, emek verenlerin eline sağlık.
Görevi = PC deki bir klasör içindeki dosyaları listeliyor.

Benim ihtiyacım olan ek özellik şöyle ;
1 - klasör içindeki dosyaları hem dizin hemde uzantısı ile listeliyor.
Buna sadece "dosya adını" listele gibi bir seçenek mümkünmü

Yardımlarınız için şimdiden çok çok teşekkürler.
 

Ekli dosyalar

Aşağıdaki iki kodu eskileri ile değiştirin.
Kod: 
Private Sub Liste(Yol As String)
j = [a65000].End(3).Row + 1
Dim Dosya As String, i As Long
Dosya = Dir(Yol & "\*.*")
While Dosya <> ""
DoEvents
'Cells(j, 1) = Yol & Dosya
Cells(j, 1) = Dosya
j = j + 1
Dosya = Dir
Wend

End Sub
 
Private Sub AltListe(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
Dosya = Dir(f.Path & "\*.*")
    
While Dosya <> ""
DoEvents
j = [a65000].End(3).Row + 1
'Cells(j, 1) = f.Path & "\" & Dosya
Cells(j, 1) = Dosya

Dosya = Dir
Wend
AltListe (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Buda alternatif olsun

Kod: 
Dim Klasor As Object
Dim sat As String
Sub bul()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
Kaynak = Klasor.SELF.Path
sat = 1
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Columns("A:A").ClearContents
Liste (Kaynak)
Application.ScreenUpdating = True
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
End Sub
Private Sub Liste(Klasor As String)
Dim fL As Object, f As Object, Dosya As String
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).subfolders
sat1 = sat
Dosya = Dir(Klasor & "\*.**")
While Dosya <> ""
DoEvents
Cells(sat1, 1).Value = Dosya
sat1 = sat1 + 1
Dosya = Dir
Wend
sat = sat1
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
 
Sayın halit3;

Klasör içindeki dosyaları listeleme ile ilgili kodları inceledim. Teşekkürler. Aşağıdaki kodlar üzerinde revize yaparak klasör ismini değişken yapabilirmiyiz?
Burada "ChDir ("c:\prp")" değişken olmalı


Sub DosyalariListele1()
Dim Dosya
Dim i As Integer
ChDir ("c:\prp")
Dosya = Dir("*.*")
i = 1
While Dosya <> ""
Cells(i, 1) = Dosya
Dosya = Dir
i = i + 1
Wend
End Sub
 
levo26' Alıntı:
Sayın halit3;

Klasör içindeki dosyaları listeleme ile ilgili kodları inceledim. Teşekkürler. Aşağıdaki kodlar üzerinde revize yaparak klasör ismini değişken yapabilirmiyiz?
Burada "ChDir ("c:\prp")" değişken olmalı


Sub DosyalariListele1()
Dim Dosya
Dim i As Integer
ChDir ("c:\prp")
Dosya = Dir("*.*")
i = 1
While Dosya <> ""
Cells(i, 1) = Dosya
Dosya = Dir
i = i + 1
Wend
End Sub
Genişletmek için tıkla ...

3 nolu mesajda var zaten sizin gönderdiğiniz kodda klasör tek başına, değişkene atamak için yukarıdaki mesajdaki gibi klasörleri değikene yani döngüye atamak gerekiyor.
 
hamitcan hocam çok teşekkür ederim. ancak kodları butona makro atayamadım.
halit3 hocam sizede çok teşekkür ederim. istediğim gibi dosya dizinini yazmadan listeliyor. ancak dosya uzantılarını yazyor. aceba bu dosya uzantısı ve diznini listelemede gözükmesini seçenek haline getirebilirmiyiz. tekrardan teşekkürler ellerinize sağlık.
 
Gorarr' Alıntı:
hamitcan hocam çok teşekkür ederim. ancak kodları butona makro atayamadım.
halit3 hocam sizede çok teşekkür ederim. istediğim gibi dosya dizinini yazmadan listeliyor. ancak dosya uzantılarını yazyor. aceba bu dosya uzantısı ve diznini listelemede gözükmesini seçenek haline getirebilirmiyiz. tekrardan teşekkürler ellerinize sağlık.
Genişletmek için tıkla ...

Dizinleri ve uzantılara evet veya haır seçeneği eklenmiştir.

kod

Kod: 
Dim Klasor As Object
Dim sat As String
Dim sat1 As String
Dim goster As String
Dim dizin As String
Sub bul()
a = MsgBox("Dosyaların uzantıları gösterilsinmi!?", vbYesNo + vbInformation, " uyarı")
If a = vbYes Then
goster = 0
Else
goster = 1
End If
b = MsgBox("Dosyaların dizinlerini gösterilsinmi!?", vbYesNo + vbInformation, " uyarı")
If b = vbYes Then
dizin = 0
Else
dizin = 1
End If
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
sat1 = 1
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Columns("A:A").ClearContents
Liste (Kaynak)
Application.ScreenUpdating = True
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
End Sub
Private Sub Liste(Klasor As String)
Dim fL As Object, f As Object, Dosya As String
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).subfolders
sat = sat1
Dosya = Dir(Klasor & "\*.**")
While Dosya <> ""
DoEvents
deg = Dosya
If goster = 1 Then
If dizin = 1 Then
For i = Len(deg) To 1 Step -1
If Mid(deg, i, 1) = "." Then
Cells(sat, 1).Value = Mid(deg, 1, i - 1)
Exit For
End If
Next
Else
For i = Len(deg) To 1 Step -1
If Mid(deg, i, 1) = "." Then
Cells(sat, 1).Value = Klasor & "\" & Mid(deg, 1, i - 1)
Exit For
End If
Next
End If
Else
If dizin = 1 Then
Cells(sat, 1).Value = Dosya
Else
Cells(sat, 1).Value = Klasor & "\" & Dosya
End If
End If
sat = sat + 1
Dosya = Dir
Wend
sat1 = sat
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
 
Sayın halit3;
Bir zamanlar Haluk arkadaşımız vardı forumda. Aşağıdaki kodlar ona ait. Kodlar ile; klasör içindeki dosya isimlerini listeleyebildiğimiz gibi, en son ne zaman kaydedildiği, mb.... gibi özellikleri ile döküm yapıyor ve ayrıca da dosyalara link verebiliyor. Ama kod "Range sınıfının NumberFormat özelliği kurulamıyor" şeklinde hata veriyor. Kodlar çok özel/Güzel. Eğer vaktiniz olursa bir çözüm bulabilirmiyiz? Saygılar..

Const MyExt As String = "*.xls"
Const IncludeSubFolder As Boolean = True
Dim MyPath As String
Dim FileSize, Folder, LastModified, LastAccessed
'
Sub FileList()
Dim FileNamesList As Variant, i As Long
Range("A:E").ClearContents
On Error GoTo ErrHandler:
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.Items.Item.Path
If InStr(1, MyPath, Application.PathSeparator) < 1 Then Err.Raise (91)
FileNamesList = CreateFileList(MyExt, IncludeSubFolder)
Range("A1") = "Dosya Adı"
Range("B1") = "Dosya Boyutu"
Range("C1") = "Klasor"
Range("D1") = "Son Değişiklik"
Range("E1") = "Son Kullanma"
Range("A1:E1").Font.Bold = True
Range("A1:E1").Font.Size = 12
Range("B:B").NumberFormat = "0.00 Kb" 'BU SATIRI SİLERSEM ÇALIŞIYOR SORUN BURADAFor i = 1 To UBound(FileNamesList)
Cells(i + 1, 1) = Dir(FileNamesList(i))
Call FileDetails(FileNamesList(i))
Cells(i + 1, 2) = FileSize
Cells(i + 1, 3) = Folder
Cells(i + 1, 4) = LastModified
Cells(i + 1, 5) = LastAccessed
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:=FileNamesList(i)

Columns("A:E").AutoFit
End If
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
Exit Sub
ErrHandler:
Select Case Err.Number
Case 7
MsgBox "Disket veya CD-ROM/WRITER sürücüsü boş !", vbOKOnly, "HATA !"
Case 13
MsgBox "Klasorde geçerli *.xls dosyası bulunamadı !", vbOKOnly, "HATA !"
Case 91
MsgBox "Geçerli bir klasor seçilmedi !", vbOKOnly, "Hata !"
Case Else
MsgBox "Hata oluştu !" & vbCrLf & vbCrLf & "Hata No: " & Err.Number & vbCrLf & Err.Description, vbOKOnly, "HATA !"
End Select
Err.Clear
Range("A1:E1").Clear
End Sub
'
Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
With Application.FileSearch
.NewSearch
.LookIn = MyPath
.Filename = FileFilter
.LastModified = msoLastModifiedAnyTime
.SearchSubFolders = IncludeSubFolder
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next
End With
CreateFileList = FileList
Erase FileList
End Function
'
Sub FileDetails(FilePath)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(FilePath)
FileSize = f.Size / 1024
Folder = f.ParentFolder
LastModified = Format(f.DateLastModified, "dd.mmmm.yyyy")
LastAccessed = Format(f.DateLastAccessed, "dd.mmmm.yyyy")
Set f = Nothing
Set fs = Nothing
End Sub
Genişletmek için tıkla ...
 
Son düzenleme:
Halit hocam #8 nolu mesajınızdaki kodları denedim. ancak bir hata olasa gerek birçok dosyayı listelemiyor. kontrol etmeniz mümkünmü. "olmazsada sağlık olsun bir önceki kodlarınız tam istediğim gibiydi, uzantıları elle silerim". emeğiniz için çok teşekkürler.
 
Gorarr' Alıntı:
Halit hocam #8 nolu mesajınızdaki kodları denedim. ancak bir hata olasa gerek birçok dosyayı listelemiyor. kontrol etmeniz mümkünmü. "olmazsada sağlık olsun bir önceki kodlarınız tam istediğim gibiydi, uzantıları elle silerim". emeğiniz için çok teşekkürler.
Genişletmek için tıkla ...

8 nolu mesajdaki kodu yeniden düzenledim.
 
levo26' Alıntı:
Sayın halit3;
Bir zamanlar Haluk arkadaşımız vardı forumda. Aşağıdaki kodlar ona ait. Kodlar ile; klasör içindeki dosya isimlerini listeleyebildiğimiz gibi, en son ne zaman kaydedildiği, mb.... gibi özellikleri ile döküm yapıyor ve ayrıca da dosyalara link verebiliyor. Ama kod "Range sınıfının NumberFormat özelliği kurulamıyor" şeklinde hata veriyor. Kodlar çok özel/Güzel. Eğer vaktiniz olursa bir çözüm bulabilirmiyiz? Saygılar..
Genişletmek için tıkla ...

Kod: 
Range("B:B").NumberFormat = "0.00 Kb"

bu bölümü aşağıdakiyle değiştirin

Kod: 
Range("B:B").NumberFormat = "0.00 ""kb"""
 
Halit hocam ellerinize sağlık tam istediğim gibi oldu. saygılar selamlar...
 
Arkadaşlar örnekleri inceledim,aramada yaptım bulamadım, benim şu şekilde sorum var yardımcı olursanız sevinirim,

Private Sub silincek_Click()
On Error Resume Next
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.DeleteFolder "C:\HAKAAN\" & firma.Caption & yıl.Caption, True
End Sub

Bu formülde "C:\HAKAAN\" klasöründe ilgili firma klasörünü bulamazsa beni uyarsın
klasör yok desin, işlemi durdursun, yapma imkanımız varmı acaba, yardımlarınız için şimdiden teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst