'اين قسمت را در ماژول قرار دهيد
Option Explicit

Private Sub TraverseFolder(ByVal Path As String, _
                           ByVal Recordset As Recordset, _
                           ByVal SubFolders As Boolean)
    Dim strFSName As String 'A filesystem name (folder or file).
    Dim strFullPath As String
    Dim intAttr As Integer
    Dim colFolders As New Collection 'Holds folder fullpaths.
    Dim lngDelim As Long
    Dim varFullPath As Variant
   
    If Right$(Path, 1) = "\" Then Path = Left$(Path, Len(Path) - 1)
    If SubFolders Then
        'Report folder.
        lngDelim = InStrRev(Path, "\", Len(Path) - 1)
        With Recordset
            .AddNew
            !Name = Mid$(Path, lngDelim + 1)
            Path = Path & "\" 'Add "\" for folder names AND for Dir() below.
            !FullName = Path
            !Extension = ""
            !Size = 0
            !Attributes = GetAttr(Path)
            !IsFolder = True
            .Update
        End With
    Else
        'Just fix up Path.
        Path = Path & "\"
    End If
       
    strFSName = Dir(Path, vbDirectory)
    Do Until Len(strFSName) = 0
        strFullPath = Path & strFSName
        If (GetAttr(strFullPath) And vbDirectory) <> 0 Then
            'Cache interesting folders.
            If SubFolders And strFSName <> "." And strFSName <> ".." Then
                colFolders.Add strFullPath
            End If
        Else
            'Report file.
            lngDelim = InStrRev(strFSName, ".")
            With Recordset
                .AddNew
                !FullName = strFullPath
                !Name = strFSName
                !Extension = Mid$(strFSName, lngDelim + 1)
                !Size = FileLen(strFullPath)
                !Attributes = intAttr
                !IsFolder = False
                .Update
            End With
        End If
        strFSName = Dir()
    Loop
   
    'Process subfolders if we cached any.
    For Each varFullPath In colFolders
        TraverseFolder varFullPath, Recordset, SubFolders
    Next
End Sub

Public Function GetFiles(ByVal Path As String, _
                         Optional ByVal SubFolders As Boolean = True) _
                         As Recordset
    'Returns an open Recordset with one record per
    'file found in the filesystem path Path.  If
    'SubFolders is True then the filesystem tree
    'below Path is recursed.
    Const MAX_PATH = 260
   
    Set GetFiles = New Recordset
    With GetFiles
        With .Fields
            .Append "FullName", adLongVarChar, MAX_PATH
            .Append "Name", adLongVarChar, MAX_PATH
            .Append "Extension", adVarChar, 255
            .Append "Size", adInteger
            .Append "Attributes", adSmallInt
            .Append "IsFolder", adBoolean
        End With
        .Open
        TraverseFolder Path, GetFiles, SubFolders
    End With
End Function

'اين قسمت را در فرم قرار داده کنترل هاي لازم را روي فرم بگذاريد

Option Explicit

Private rsFiles As Recordset

Private Function FmtSize(ByVal Value As Long) As String
    FmtSize = Right$(Space$(12) _
            & Format$(Value, "#,###,###,##0 "), 14)
End Function

Private Sub cmdDisplay_Click()
    With rsFiles
        If chkFolders.Value = vbUnchecked Then
            .Filter = "IsFolder = False"
        End If
        If .RecordCount > 0 Then
            .Sort = "Size ASC"
            Do Until .EOF
                txtDisplay.SelStart = Len(txtDisplay.Text)
                txtDisplay.SelText = IIf(!IsFolder, _
                                         Space$(5) & "[Folder] ", _
                                         FmtSize(!Size)) _
                                   & !FullName & vbNewLine
                .MoveNext
            Loop
            txtDisplay.SelStart = 0
        Else
            txtDisplay.Text = "*none*"
        End If
        .Close
    End With
    Set rsFiles = Nothing
    chkFolders.Enabled = False
    cmdDisplay.Enabled = False
    txtFolder.Enabled = True
    cmdGetFiles.Enabled = True
    DoEvents
    txtFolder.SetFocus
End Sub

Private Sub cmdGetFiles_Click()
    Dim sngTimer As Single
   
    lblTime.Caption = ""
    lblItems.Caption = ""
    txtDisplay.Text = ""
    sngTimer = Timer()
    Set rsFiles = GetFiles(txtFolder.Text)
    sngTimer = (Timer() - sngTimer)
    lblTime.Caption = Format(TimeSerial(0, 0, Int(sngTimer)), "HH:NN:SS") _
                    & Format(sngTimer - CSng(Int(sngTimer)), ".000")
    lblItems.Caption = CStr(rsFiles.RecordCount)
    txtFolder.Enabled = False
    cmdGetFiles.Enabled = False
    chkFolders.Enabled = True
    cmdDisplay.Enabled = True
    chkFolders.SetFocus
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Not (rsFiles Is Nothing) Then
        If rsFiles.State = adStateOpen Then rsFiles.Close
        Set rsFiles = Nothing
    End If
End Sub