Private Sub OK_Click()
If TypeName(Selection) <> "Range" Then
MsgBox "Please select a range.", vbCritical, AT
Exit Sub
Else
On Error Resume Next
Application.StatusBar = "Now processing...."
ActiveCell.Value = "Filename:"
If ChkFileSize Then ActiveCell.Offset( 0 ,  1 ).Value = "Filesize"
If chkFileDate Then ActiveCell.Offset( 0 ,  2 ).Value = "Filedate"
ActiveCell.Offset( 1 ,  0 ).Activate
Set fs = Application.FileSearch
fs.NewSearch
If SearchDirectory = "" Then
MsgBox "Sorry, no directory to search", vbCritical, AT
Exit Sub
End If
With fs
.LookIn = SearchDirectory
.SearchSubFolders = IncludeSubfolders
.FileType = msoFileTypeAllFiles
.Filename = SearchFileTypes
.MatchTextExactly = False
If .Execute() >  0  Then
Application.ScreenUpdating = False
For i =  1  To .FoundFiles.Count
strFileName = .FoundFiles(i)
If strFileName Like SearchFileTypes Then
ActiveCell.Value = strFileName
If ChkFileSize = True Then ActiveCell.Offset( 0 ,  1 ).Value = Int(FileLen(strFileName) /  1024 ) & " kb"
If chkFileDate = True Then ActiveCell.Offset( 0 ,  2 ).Value = FileDateTime(strFileName)
ActiveCell.Offset( 1 ,  0 ).Activate
End If
Next i
Application.ScreenUpdating = True
fs = Empty
Else
MsgBox "Sorry, no files found.", vbCritical, AT
End If
End With
ActiveCell.EntireColumn.AutoFit
If IncludeSubfolders.Value = True Then ActiveCell.Offset( 0 ,  1 ).EntireColumn.AutoFit
If chkFileDate.Value = True Then ActiveCell.Offset( 0 ,  2 ).EntireColumn.AutoFit
fs = Empty
Application.StatusBar = False
End If
End Sub

Private Sub UserForm_Initialize()
HideCloseButton Me
Me.MpFileName.Value =  0 
SearchDirectory.Value = Empty
IncludeSubfolders.Value = False
SearchFileTypes.Value = "*.*"
On Error GoTo ErrNoPrinter
Dim strNothing As String
strNothing = ActiveSheet.PageSetup.LeftHeader
Exit Sub
ErrNoPrinter:
lblPageHeaderFooter.Caption = "You don't have a printer installed." & vbNewLine & _
"Without a printer you can't adjust the header and footer."
Me.CmdFootercenter.Enabled = False
Me.CmdFooterleft.Enabled = False
Me.CmdFooterright.Enabled = False
Me.CmdHeadercenter.Enabled = False
Me.CmdHeaderleft.Enabled = False
Me.CmdHeaderright.Enabled = False
End Sub

Sub ListFiles()
    Dim Msg As String
    Dim Directory As String
    Dim r As Long, i As Long
    
    Msg = "Óêàæèòå ðàñïîëîæåíèå ïàïêè, äëÿ êîòîðîé îòîáðàæàåòñÿ ñïèñîê ôàéëîâ."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory,  1 ) <> "\" Then Directory = Directory & "\"
    
'   Âñòàâêà çàãîëîâîêîâ
    r =  1 
    Cells.ClearContents
    Cells(r,  1 ) = "Èìÿ ôàéëà"
    Cells(r,  2 ) = "Ðàçìåð"
    Cells(r,  3 ) = "Äàòà/âðåìÿ"
    Range("A1:C1").Font.Bold = True
    r = r +  1 

    On Error Resume Next
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        .Filename = "*.*"
        .SearchSubFolders = True
        .Execute
        For i =  1  To .FoundFiles.Count
            Cells(r,  1 ) = .FoundFiles(i)
            Cells(r,  2 ) = FileLen(.FoundFiles(i))
            Cells(r,  3 ) = FileDateTime(.FoundFiles(i))
            r = r +  1 
        Next i
    End With
End Sub

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

' Êîðíåâàÿ ïàïêà = Ðàáî÷èé ñòîë
    bInfo.pidlRoot =  0 &

' Çàãîëîâîê îêíà
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If

' Òèï âîçâðàùàåìîé ïàïêè
    bInfo.ulFlags = &H1

' Îòîáðàæåíèå îêíà
    x = SHBrowseForFolder(bInfo)

' Ïðåäñòàâëåíèå ðåçóëüòàòà
    path = Space$( 512 )
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$( 0 ))
        GetDirectory = Left(path, pos -  1 )
    Else
        GetDirectory = ""
  End If
End Function