Klasör İçindeki Fotografları Sayma

alt klasörleri de aynı satırda toplam olarak sonuç alabilirmiyiz

Yukardaki yeri tam anlayamadım ne demek istediğinizi.Excelde sonuçları nasıl çıkacağını gösterebilirmisiniz satırlarda.

Ayrıca eğer accesste tabloda görmek istiyorsanız yaptığım kodlar insert into ile tabloya uyarlanabilir diye düşünüyorum.
Yani png ve jpg adetlerini bulduğumuza göre kodla sadece ilgili yerleri insert into ile aktarlır tabloya.
Yani excelde tam herşey biterse accese uygulanması kolay olur.Ve eklediğim kod uygun Access için.

Hocam benim arşiv sistemin örnektekine benzer bişekilde onları seçerken zorluk yaşamayalım diye yazmıştım

Eklediğiniz resimde Kls2* ve Kls5* eklemişsiniz.Sadece bu iki klasördemi aranacak tam anlayamıyorum.
Metin olarak alfabetik sıralatma ise metin ve sayı birleşik olduğğu için tam olmayacağını sanıyorum.

Ayrıca mantık hatası olmuş A sütunu için.


yukardaki yerine alttaki olacak çünkü resim uzantısına gerek yok.Esasen A sütunada gerek yok ilk denemelerimden kalan birşey.Eğer köprü eklerseniz A sütununa o klasörü açar.

hayır üstadım benim saydırma yapacağım klasör çok fazla ve isimleri değişik başlangıçları sıralı olarak gidiyor sonuna eklediğim * farklı kelmeler veta sayılar içeriyor * onun için koydum saydırmak için iki farklı kombinasyon belirlenecek

Esas saydırmak istediğim klasör isimleri

Rp.2020-150 Evden hısızlık
Rp.2020-151 İşyerinden hırsızlık
.
.
.
.
.
.
.
Rp.2020-200 Yaralama

gibi bu sayı sürekli artıyor ben bunları aylık belirli dosyaları saydıracağım

ilgin için teşekkürler

Merhaba.
Tam olarak anladımmı bilemiyorum anladığım kadarıyla yaptım.




Kodlar altta.Eğer sonuçlar doğruysa Access dosyanızı yükleyin ona uyarlarız.

PHP Kod:

Const sayAd As String = "Sayfa1"
Dim say As Long
Dim arr

Sub AraNumaraVer1()

    Dim AltDosyalar As Object
    Dim Dosyalar  As Object
    Dim dosya As Object
    Dim fso As Object
    Dim DosyaAc As String
    
    Sheets(sayAd).Range("H10:H" & Rows.Count).ClearContents
say = 0
    
    With Application.FileDialog(msoFileDialogFolderPicker)
          .InitialFileName = ThisWorkbook.path & "\"
        If .Show = -1 Then
            DosyaAc = .SelectedItems(1)
        Else
            MsgBox "iptal edildi", vbExclamation, "iptal"
            Exit Sub
        End If
    End With
    
    ReDim arr(1 To 1, 1 To 1000000)
        
    If DosyaAc <> "" Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dosyalar = fso.Getfolder(DosyaAc)

    ReDim arr(1 To 1, 1 To 1000000)

    With Sheets(sayAd)
        For Each dosya In Dosyalar.SubFolders
            a = InStr(1, fso.GetBaseName(dosya), " ")
            If a > 0 Then b = Mid(fso.GetBaseName(dosya), 1, a - 1)
            
            c = Val(Mid(b, 4, Len(b)))
            d = Val(Mid(Sayfa2.TextBox1.Value, 4, Len(Sayfa2.TextBox1.Value)))
            e = Val(Mid(Sayfa2.TextBox2.Value, 4, Len(Sayfa2.TextBox2.Value)))
            If c > e Then Exit For
            If Val(Mid(b, 4, Len(b))) >= Val(Mid(Sayfa2.TextBox1.Value, 4, Len(Sayfa2.TextBox1.Value))) Then
                Call DosyaAraAlt(dosya)
            End If

        Next
    End With
    MsgBox "Bitti", vbInformation, "Bitti"
    Sheets(sayAd).Range("H10").Resize(UBound(arr, 2), 1).Value = Application.Transpose(arr)
End If
    On Error Resume Next
    Set fso = Nothing
    Set Dosyalar = Nothing
    Set dosya = Nothing
    Erase arr
End Sub

Sub DosyaAraAlt(ByVal path As String)

    Dim AltDosyalar As Object
    Dim Dosyalar  As Object
    Dim dosya As Object
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dosyalar = fso.Getfolder(path)

    With Sheets(sayAd)
        For Each dosya In Dosyalar.SubFolders
            say = say + 1
            ReDim Preserve arr(1 To 1, 1 To say)
            arr(1, say) = say & "- " & fso.GetBaseName(dosya)
        Next
    End With
    
    For Each AltDosyalar In Dosyalar.SubFolders
        Call DosyaAraAlt(AltDosyalar.path)
    Next

    On Error Resume Next
    Set fso = Nothing
    Set AltDosyalar = Nothing
    Set Dosyalar = Nothing
    Set Fileler = Nothing

    
End Sub 


PHP Kod:

Dim say3 As Long
Dim yolAl As String 'Ana Klasor yol
Const SayfaAd As String = "Sayfa1"

Private Sub CommandButton1_Click()
    With Sheets(SayfaAd)
        .Range("A3:F" & Rows.Count).ClearContents
        yolAl = ThisWorkbook.path & "\Arsiv\Kls3 Mustafa" 'Ana Klasor yol sadece burasi degisecek
        Call DosyaAraAlt(yolAl, 1) '1 ana klasörler icin
        Call DosyaAraAlt(yolAl, 2) '2 alt klasörler icin
    End With
    say3 = 0
    say3 = Empty
End Sub

Sub DosyaAraAlt(ByVal path As String, alan As Byte)

    Dim AltDosyalar As Object
    Dim Dosyalar  As Object
    Dim Fileler As Object
    Dim fso As Object
    Dim say As Long, say1 As Long, say2 As Long, son As Long
    Dim scr As Object
    Dim arr
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set arama = CreateObject("Scripting.Dictionary")
    say = 0: say1 = 0: say2 = 0
    
    Set Dosyalar = fso.Getfolder(path)
    
    Application.ScreenUpdating = False

    say = say + 1
    say3 = say3 + 1
    
    With Sheets(SayfaAd)
        ReDim arr(1 To 4, 1 To 1)
    
        For Each Fileler In Dosyalar.Files
            If UCase(fso.GetExtensionName(Fileler)) = "JPG" Then say1 = say1 + 1
            If UCase(fso.GetExtensionName(Fileler)) = "PNG" Then say2 = say2 + 1
            a = fso.GetParentFolderName(Fileler)
            b = fso.GetBaseName(path)
        Next
        If say1 > 0 Or say2 > 0 Then
            arr(1, say) = a
            arr(2, say) = b
            arr(3, 1) = say1
            arr(4, 1) = say2
            
            If alan = 1 Then
                .Range("A3").Resize(1, 4) = Application.Transpose(arr)
                GoTo var
            ElseIf alan = 2 Then
          If say3 = 2 Then GoTo var2
                son = .Cells(Rows.Count, 1).End(3).Row + 1
                .Range("A" & son).Value = a
                .Range("B" & son).Value = b
                .Range("E" & son).Value = say1
                .Range("F" & son).Value = say2
            End If
        End If
var2:
      For Each AltDosyalar In Dosyalar.SubFolders
        Call DosyaAraAlt(AltDosyalar.path, 2)
      Next
        
    End With
var:

    Application.ScreenUpdating = True
    On Error Resume Next
    Set fso = Nothing
    Set AltDosyalar = Nothing
    Set Dosyalar = Nothing
    Set Fileler = Nothing
    Set scr = Nothing
    Erase arr
End Sub