Klasörde belirttiğim uzantılı dosyaları bulup listeleme makrosu

[TanerSaydam]

Herkese merhaba arkadaşlar;

İç içe yüzlerce oluşan bir klasörde .lua uzantılı dosyaların hangi klasörlerde olduğunu bulmam gerekiyor. C:\1\ aramaya buradan başlıyacak ve içerideki tüm klasörde bu dosyalar varsa konumunu A sütununa sırayla yazacak. Nette çok aradım ama ya doğru şekilde aramadım ya da yok çünkü istediğimi bulamadım. Ustalarımızdan ve sizlerden kod için yardım bekliyorum.

Şimdiden teşekkürler.

 

[antonio]

Merhaba,
Dosya gezgininde "Bilgisayarım" seçili iken sağ tarafta ki arama yerine "*.lua " yazarak arama yapabilirsiniz.

 

[acar6783]

Sub MainList()

'Set klasör = Application.FileDialog(msoFileDialogFolderPicker)

'If klasör.Show <> -1 Then Exit Sub
ActiveSheet.Range("A2:B" & Rows.Count).ClearContents
xDir = "C:\1" 'klasör.SelectedItems(1)

Call KlasörListele(xDir, True)
End Sub
Sub KlasörListele(ByVal klasöradı As String, ByVal xIsSubfolders As Boolean)
Dim dosya As Object
Dim xklasör As Object
Dim xaltklasör As Object
Dim xFile As Object
Dim satır As Long
Set dosya = CreateObject("Scripting.FileSystemObject")
Set xklasör = dosya.GetFolder(klasöradı)
With ActiveSheet

satır = .Range("A65536").End(xlUp).Row + 1
For Each xFile In xklasör.Files
If Right(xFile.Name, 4) = ".lua" Then
.Cells(satır, 1) = xFile.Name
.Cells(satır, 2) = xFile.Path

  satır = satır + 1
  End If
Next xFile
If xIsSubfolders Then
  For Each xaltklasör In xklasör.SubFolders
    KlasörListele xaltklasör.Path, True
  Next xaltklasör
End If
End With
Set xFile = Nothing
Set xklasör = Nothing
Set dosya = Nothing
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xklasör As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xklasör = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xklasör Is Nothing Then
  Set xFolderItem = xklasör.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xklasör.GetDetailsOf(xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xklasör = Nothing
Set xFolderItem = Nothing
End Function

Kodlarını deneyiniz istediğiniz olacaktır.

 

[veyselemre]

Sub test()
    Columns(1).ClearContents
    With CreateObject("WScript.Shell").Exec("cmd.exe /C dir C:\1\*.lua /s/b").StdOut
        While Not .AtEndOfStream
            sLine = .ReadLine
            If sLine <> "" Then
                s = s + 1
                Cells(s, 1) = sLine
            End If
        Wend
    End With
End Sub

 test2()
    Columns(2).ClearContents
    CreateObject("WScript.Shell").Exec ("cmd.exe /C dir C:\1\*.lua /s/b >c:\sil.txt")
    With CreateObject("Scripting.FileSystemObject").OpenTextFile("c:\sil.txt")
        While Not .AtEndOfStream
            sLine = .ReadLine
            If sLine <> "" Then
                s = s + 1
                Cells(s, 2) = sLine
            End If
        Wend
        .Close
    End With
End

 

[Tevfik_Kursun]

Sayın Acar6783 ve Sayın Veyselemre Hocalarım,
Teşekkürler, her üçü de güzel çalışıyor. test2 adlı makroya 4. satırı ekledim, sil.txt dosyasını bulamadım deyip atıyordu. (bilgiçlik taslıyor demeyin ha, affınıza sığınarak ekledim)
Saygılarımla

 Sub test2()
    Columns(2).ClearContents
    CreateObject("WScript.Shell").Exec ("cmd.exe /C dir C:\Users\Hp\Desktop\*.jpg /s/b >C:\Users\Hp\Desktop\sil.txt")
    Application.Wait (Now + TimeValue("0:00:2"))
    With CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\Users\Hp\Desktop\sil.txt")
        While Not .AtEndOfStream
            sLine = .ReadLine
            If sLine <> "" Then
                s = s + 1
                Cells(s, 2) = sLine
            End If
        Wend
        .Close
    End With
End Sub

 

[veyselemre]

test2 adlı makroya 4. satırı ekledim, sil.txt dosyasını bulamadım deyip atıyordu. (bilgiçlik taslıyor demeyin ha, affınıza sığınarak ekledim)

Çok hızlı bilgisayarınız varmış, bende öyle bir sorun çıkmadı. Burda bilgiçlik taslamak filan söz konusu olamaz, herkes her şeyi düşünemez, o anda göremez.

Ben elimden geldiğince kısa ve değişik kod yazmaya çalışıyorum ki; bu işin bana bir katkısı olsun yoksa aynı kodları kopyala yapıştır üç beş yerini değiştir bana bir faydası olmaz. Benim düzenli bir arşivim bile yok. Her seferinde sıfırdan kod yazıyorum. Bilgim haricinde veya unutulacak kalıpları o anda internet ten araştırıp gerekli kodları bulup düzenliyorum, en güzeli de bu her seferinde değişik bir şeyler buluyorsunuz. Sizin sorunuzu görür görmez hemen eski dos komutları aklıma gelti >yöntemiyle ekran çıktılarını yazıcıya, dosyaya aktarıyorduk. Dosyayı okumak için internetten TextStream kodunun syntaxını araştırırken Haluk Beyin bilgisayar bilgilerini gösteren bir kodu karşıma çıktı StdOut parametresini ilk defa gördüm olay 1. koda döndü denedim dir komutuyla da çalıştı ve konu uyarladım. İlk defa kullanmış oldum, tekrar lazım olur mu bilmem ama o an bir heyecan duyuyorsunuz.

Olay burda benim için bitiyor. Bundan sonrası soruyu sorana kalıyor, kendine göre düzenlemeleri yapar.

Benim en çok sinir olduğum şey örnek dosyalarda çalışan kodların kendi dosyalarında çalışmadığı zaman, kod çalışmıyor demeleri, o kadar emek sarfedip defalarca denediğiniz kodu bir saniyede harcıyorlar, hatayı kodlara buluyorlar o zaman ben bitiyorum, muhatap olmuyorum. Bazı arkadaşların sabrına şaşıyorum doğrusu defalarca düzeltmeye uğraşıyorlar, yeniden yeniden mesaj yazıyorlar, yeniden soruyorlar işin sonunu bırakmıyorlar onları tebrik etmek gerekiyor.
Saygılar...

 

[Tevfik_Kursun]

Sayın Veyselemre Hocam,
Ben de hıza yormuştum, ama belki başkasının da başına gelir diye cevaplamayı tercih ettim. Haklısınız DOS ta hala çok güzel ve işe yarayan komutlar var. Ben de hala kullanıyorum.
Tekrar teşekkür ederim
Saygılarımla