'---------------------------------------------------------------------------------------

' Модуль : modFilenames

' Автор : EducatedFool (Игорь) Дата: 13.04.2011

' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.

' http://excelvba.ru/ ICQ: 5836318 Skype: ExcelVBA.ru

' Реквизиты для оплаты: http://excelvba.ru/payments

'---------------------------------------------------------------------------------------

Sub СжатиеСпискаФайловПапки()

' Ищем файлы в заданной папке по заданной маске,

' и выводим на лист список их параметров.

' Просматриваются папки с заданной глубиной вложения.

' Call ОчисткаСписка

Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%

' ПутьКПапке$ = CurrentProject.Path & "\" '("E1") '[D1] ' берём из ячейки c1

ПутьКПапке$ = getPath()

If Len(ПутьКПапке) = 0 Then Exit Sub

МаскаПоиска$ = ".mdb" '[c2] ' MaskSearch берём из ячейки c2

ГлубинаПоиска% = 999 'Val(Range("C3")) '[c3] Depth берём из ячейки c3

If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 1 '999 ' без ограничения по глубине

' считываем в колекцию coll нужные имена файлов

Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)

Set coll = Nothing

End Sub

'Sub ОчисткаСписка()

' On Error Resume Next

' Intersect(Rows("6:" & Rows.Count), ActiveSheet.UsedRange).ClearContents

'End Sub

' ===================== код функции ===========================

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _

Optional ByVal SearchDeep As Long = 999) As Collection

' Получает в качестве параметра путь к папке FolderPath,

' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)

' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).

' Возвращает коллекцию, содержащую полные пути найденных файлов

' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

Set FilenamesCollection = New Collection ' создаём пустую коллекцию

Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject

GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск

Set FSO = Nothing:

' Application.StatusBar = False ' очистка строки состояния Excel

SysCmd acSysCmdSetStatus, False

End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _

ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)

' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO

' перебор папок осуществляется в том случае, если SearchDeep > 1

' добавляет пути найденных файлов в коллекцию FileNamesColl

On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)

If Not curfold Is Nothing Then ' если удалось получить доступ к папке

' раскомментируйте эту строку для вывода пути к просматриваемой

' в текущий момент папке в строку состояния Excel

' Application.StatusBar = "Поиск в папке: " & FolderPath

SysCmd acSysCmdSetStatus, "Поиск в папке: " & FolderPath

For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath

'.accdb

If fil.Name Like "*" & Mask Or fil.Name Like "*" & ".accdb" Then

Debug.Print fil.Path

SysCmd acSysCmdSetStatus, "Сжатие:" & fil

FileNamesColl.Add fil.Path

GetCompactReclaimedSpaceAmount False, fil.Path

End If

DoEvents ' временно передаём управление ОС

Next

SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках

If SearchDeep Then ' если надо искать глубже

For Each sfol In curfold.SubFolders ' ' перебираем все подпапки в папке FolderPath

GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep

Next

End If

Set fil = Nothing: Set curfold = Nothing ' очищаем переменные

End If

End Function