klasör içindeki dosyaları listeleme

[mozdem]

Aşağıdaki kodlar ile yada ekteki örnek dosyam ile bu kodları çalıştırdığımda dosyaları listeliyor. Ancak benim isteğim, gizli dosyalarıda listelesin.
teşekkürler
'-------------------

Sub Dosya_Listele()
Columns("A:A").ClearContents
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
Liste2 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
Dosya = Dir(Yol & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
Cells(j, 1) = ekle & Dosya
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

Dim c

Sub Dosya_Listele()
Columns("A:A").ClearContents
c = 0
Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If klasor Is Nothing Then
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
Exit Sub
End If
klasoradi = klasor.self.Path
Liste2 (klasoradi)
End Sub

Private Sub Liste2(Yol As String)
Set nesne = CreateObject("Scripting.FileSystemObject")
dosyasayisi = nesne.GetFolder(Yol).Files.Count
klasorsayisi = nesne.GetFolder(Yol).SubFolders.Count
If dosyasayisi > 0 Then
For Each Dosya In nesne.GetFolder(Yol).Files
c = c + 1
Cells(c, "a") = Yol & "\" & Dosya.Name
Next
End If
If klasorsayisi > 0 Then
For Each altklasor In nesne.GetFolder(Yol).SubFolders
Liste2 (altklasor)
Next
End If
End Sub

 

[mozdem]

Teşekkür

Aşağıdaki gibi deneyin.

Dim c

Sub Dosya_Listele()
Columns("A:A").ClearContents
c = 0
Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If klasor Is Nothing Then
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
Exit Sub
End If
klasoradi = klasor.self.Path
Liste2 (klasoradi)
End Sub

Private Sub Liste2(Yol As String)
Set nesne = CreateObject("Scripting.FileSystemObject")
dosyasayisi = nesne.GetFolder(Yol).Files.Count
klasorsayisi = nesne.GetFolder(Yol).SubFolders.Count
If dosyasayisi > 0 Then
For Each Dosya In nesne.GetFolder(Yol).Files
c = c + 1
Cells(c, "a") = Yol & "\" & Dosya.Name
Next
End If
If klasorsayisi > 0 Then
For Each altklasor In nesne.GetFolder(Yol).SubFolders
Liste2 (altklasor)
Next
End If
End Sub

Çok Teşekkür ederim Hocam. Elinize sağlık.

 

[halit3]

Buda alternatif olsun

Sub Dosya_Listele()
Columns("A:A").ClearContents
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
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste2 (Kaynak)
Set klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
Private Sub Liste2(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).Files
For Each dosya In fs
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Yol & dosya.Name
Next
On Error GoTo sonraki
For Each f In fL
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[mozdem]

Eğer satır 25 ten fazla ise Makrodan çıkılsın

04-02-2012, 23:39 #3
mozdem
Sorum Kodların altında

Giriş: 11/11/2005
Mesaj: 131
Excel Vers. ve Dili:
OFFICE-2003 TÜRKÇE Teşekkür

-------------------------------------------------------------------------

Alıntı:
Levent Menteşoğlu tarafından gönderildi
Aşağıdaki gibi deneyin.


Kod:
Dim c

Sub Dosya_Listele()
Columns("A:A").ClearContents
c = 0
Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If klasor Is Nothing Then
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
Exit Sub
End If
klasoradi = klasor.self.Path
Liste2 (klasoradi)
End Sub

Private Sub Liste2(Yol As String)
Set nesne = CreateObject("Scripting.FileSystemObject")
dosyasayisi = nesne.GetFolder(Yol).Files.Count
klasorsayisi = nesne.GetFolder(Yol).SubFolders.Count
If dosyasayisi > 0 Then
For Each Dosya In nesne.GetFolder(Yol).Files
c = c + 1

'****YAPMAK İSTEDİĞİM KOD***************
' if c>25 then
' ??????? Exit sub gibi
'*******************



Cells(c, "a") = Yol & "\" & Dosya.Name
Next
End If
If klasorsayisi > 0 Then
For Each altklasor In nesne.GetFolder(Yol).SubFolders
Liste2 (altklasor)
Next
End If
End Sub

'--------------------------------------------------
'yukarıdaki kodlardan satır sayısına göre (örneğin 25 ten fazla olunca) çıkış yapmak istiyorum. ancak bunu yapamadım 'Yardımlarınızı bekliyorum.