Private Sub Komut2_Click()
On Error GoTo hata
Dim klasor As Object, yol As String
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
    If klasor Is Nothing Then Exit Sub
    yol = klasor.Items.Item.Path
        ListBox1.RowSource = ""
 
    With Label1
        .Visible = True
        .Caption = "Bulunuyor..."
    End With
 
    ListBox1.RowSource = ""
    Liste (yol)
    AltListe (yol)
    Label1.Caption = "Bitti ! Toplam : " & FormatNumber(ListBox1.ListCount, 0) & "  dosya bulundu."
    Set klasor = Nothing: Exit Sub
hata: MsgBox "Sürücü boş veya hazır değil!": Label1.Visible = False
End Sub
 
Private Function Liste(yol As String)
Dim dosya As String
 
DoEvents
TextBox1.SetFocus
    dosya = Dir(yol & "\" & TextBox1.Text)
    ListBox1.RowSource = ""
    While dosya <> ""
        'ListBox1.AddItem dosya
        ListBox1.AddItem yol & "\" & dosya
        Label1.Caption = "Bulunuyor... " & FormatNumber(ListBox1.ListCount, 0) _
        & "  dosya bulundu."
        dosya = Dir
    Wend
 
Set fL = Nothing
 
End Function
 
Private Function AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String
DoEvents
 
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
TextBox1.SetFocus
    dosya = Dir(f.Path & "\" & TextBox1.Text)
 
    While dosya <> ""
        'ListBox1.AddItem dosya
        ListBox1.AddItem f.Path & "\" & dosya
        Label1.Caption = "Bulunuyor... " & FormatNumber(ListBox1.ListCount, 0) _
        & "  dosya bulundu."
        dosya = Dir
    Wend
 
    AltListe (f.Path)
sonraki:
Next
Set fL = Nothing
End Function
 
Private Sub ListBox1_DblClick(Cancel As Integer)
Dim shell_app As Object
 
Set shell_app = CreateObject("Shell.Application")
 
shell_app.Open "" & ListBox1.Value
 
Set shell_app = Nothing
 
End Sub

Private arr()  As String
Private arr2() As String '********************************
Private Secim  As String
Private durdur As Boolean '*******************************
 
Private Sub ComboBox1_Change()
Dim cmb As String
cmb = ComboBox1.Text
 
If combo_hata_control(cmb) Then
    MsgBox "Yasak karrdeşiiiim"
    SendKeys "{ESC}"
End If
 
End Sub
 
Private Function combo_hata_control( _
                cmbo As String) As Boolean
    For Each m In arr2
        If (m = cmbo) Then _
            combo_hata_control = True: Exit For
    Next
End Function
 
 
Private Sub dur_Click()
    durdur = True
End Sub
 
Private Sub Komut2_Click()
'Diziyi daha sonraki aşamalarda rahat kullanabilmek
'yeniden boyutlandırmamız gerekiyor.
Me.dur.Enabled = True
durdur = False
ReDim arr(1 To 1) As String
'Sütun başlığı..
arr(1) = String$(40, ".") & " DOSYA YOLU " & String$(40, ".")
 
'İlk etapta Sütun başlığı görünmesi içindir.
ListBox1.RowSourceType = "Liste_Doldur"
DoCmd.MoveSize , , , 6103
 
Me.Tag = 1
With Label1
    .Visible = True
    .Caption = "Bulunuyor..."
End With
'Form yüklenirken Combo hareketi 'Secim' değişkenine atanmıştı.
If Secim = "Tüm Bilgisayarda Ara" Then
    Call Tum_PC
Else
    Call Liste(Replace(Secim, "\", ""))
    Call AltListe(Secim)
End If
 
Label1.Caption = "Arama tamamlandı !!   Toplam : " & UBound(arr) - 1 & " dosya bulundu"
End Sub
 
Private Sub Tum_PC()
Dim b As Byte
 
    ComboBox1.SetFocus
    For b = 0 To ComboBox1.ListCount - 2
        DoEvents
        Call Liste(Replace(ComboBox1.ItemData(b), "\", ""))
        Call AltListe(ComboBox1.ItemData(b))
    Next
 
End Sub
Private Function Liste(yol As String)
Dim dosya As String
 
DoEvents
    TextBox1.SetFocus
 
    dosya = Dir(yol & "\" & TextBox1.Text, vbHidden + vbReadOnly + vbSystem)
    While dosya <> ""
    If durdur Then Exit Function '******************************
        Me.Tag = Me.Tag + 1
        ReDim Preserve arr(1 To Me.Tag) As String
        arr(Me.Tag) = yol & "\" & dosya
 
        Label1.Caption = "Bulunuyor... " & FormatNumber(Me.Tag - 1, 0) _
        & "  dosya bulundu." & vbCrLf & vbCrLf & _
        "Bakılan yer : " & vbCrLf & yol & "\"
 
        'Dosya diziye alındıkça liste de güncellenecektir..
        ListBox1.RowSourceType = "Liste_Doldur"
 
        dosya = Dir
    Wend
 
Set fL = Nothing
 
End Function
 
Private Function AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String
DoEvents
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    TextBox1.SetFocus
       If durdur Then Exit Function '*************************
    Label1.Caption = "Bulunuyor... " & FormatNumber(Me.Tag - 1, 0) _
        & "  dosya bulundu." & vbCrLf & vbCrLf & _
        "Bakılan yer : " & vbCrLf & f.Path
 
    dosya = Dir(f.Path & "\" & TextBox1.Text, vbHidden + vbReadOnly + vbSystem)
 
    While dosya <> ""
    If durdur Then Exit Function '****************************
        Me.Tag = Me.Tag + 1
        ReDim Preserve arr(1 To Me.Tag) As String
        arr(Me.Tag) = f.Path & "\" & dosya
 
        Label1.Caption = "Bulunuyor... " & FormatNumber(Me.Tag - 1, 0) _
        & "  dosya bulundu." & vbCrLf & vbCrLf & _
        "Bakılan yer : " & vbCrLf & f.Path
 
        'Dosya diziye alındıkça liste de güncellenecektir..
        ListBox1.RowSourceType = "Liste_Doldur"
 
        dosya = Dir
    Wend
 
    AltListe (f.Path)
sonraki:
Next
Set fL = Nothing
End Function
 
Private Function Liste_Doldur( _
ctl As Control, varId As Variant, lngRow As Long, lngCol As Long, intCode As Integer)
 
    Select Case intCode
        Case acLBInitialize
              Liste_Doldur = True
        Case acLBOpen
             Liste_Doldur = Timer
        Case acLBGetRowCount
            Liste_Doldur = -1
        Case acLBGetColumnCount 'Değiştirebilirsiniz..
            Liste_Doldur = UBound(arr, 2)
        Case acLBGetColumnWidth 'Değiştirebilirsiniz..
            Liste_Doldur = 10 * 1440
        Case acLBGetValue 'Değiştirebilirsiniz ancak
            'iki boyutlu veya array base 0 durumda farklıdır Ör:
            'Liste_Doldur = arr(lngRow , lngCol )
            Liste_Doldur = arr(lngRow + 1)
    End Select
End Function
 
 
 
Private Sub ListBox1_DblClick(Cancel As Integer)
Dim shell_app As Object
 
Set shell_app = CreateObject("Shell.Application")
 
shell_app.Open "" & ListBox1.Value
 
Set shell_app = Nothing
End Sub
 
Private Sub Form_Load()
Dim Drives As Object, Drive As Object, z As Byte
 
Erase arr
ComboBox1.RowSource = ""
Set Drives = CreateObject("Scripting.FileSystemObject").Drives
 
With ComboBox1
    For Each Drive In Drives
        z = z + 1
        ReDim arr2(1 To z) As String
        If Drive.IsReady Then _
            .AddItem Drive & "\": arr2(z) = Drive & "\"
    Next
 
    .AddItem "Tüm Bilgisayarda Ara" '*******************************
    .SetFocus
    .Value = "Tüm Bilgisayarda Ara"  '************************
    Secim = "Tüm Bilgisayarda Ara"
    '.Text = ComboBox1.ItemData(ComboBox1.ListCount - 1)
End With
 
Set Drives = Nothing
End Sub
 
Private Sub ComboBox1_Click()
    Secim = ComboBox1.Text
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Erase arr
    Erase arr2
    Secim = Empty
   ' ComboBox1.RowSource = ""
End Sub
 
Private Sub Form_Open(Cancel As Integer)
 
    DoCmd.MoveSize , , , 4880
 
End Sub