Public k As Byte
Public mmm As Byte
Public zzz As Byte
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
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
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
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
Sub FilenamesCollection_80020_с_потерями()
' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.
' Просматриваются папки с глубиной вложения не более трёх.
Application.ScreenUpdating = False
Dim coll As Collection, ПутьКПапке As String
' получаем путь к папке РАБОЧИЙ СТОЛ
'ПутьКПапке = "Y:\Otdel\1.ПОКУПКА\X-files\на списание\АСКУЭ\йОПТ\80020\На отправку\2010 год\08 август\с потеряшками" 'CreateObject("WScript.Shell").SpecialFolders("Desktop")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "/"
.Title = "Укажите папку с файлами"
If .Show = False Then Exit Sub
Folder = .SelectedItems.Item(1)
End With
ПутьКПапке = Folder
' считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(ПутьКПапке, ".xml", 3)'ВОТ В ЭТОМ МЕСТЕ И ПРОИСХОДИТ ЗАГВОЗДКА
Application.ScreenUpdating = False ' отключаем обновление экрана
' создаём новую книгу
Dim sh As Worksheet: Set sh = Sheets("Пути")
sh.Range("a1:C100").Clear
sh.Range("F2:K100").Clear
' формируем заголовки таблицы
With sh.Range("a1").Resize(, 3)
.Value = Array("№", "Имя файла", "Полный путь")
.Font.Bold = True: .Interior.ColorIndex = 17
End With
k = 0
' выводим результаты на лист
For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
' sh.Range("a" & sh.Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
Array(i, Dir(coll(i)), coll(i)) ' выводим на лист очередную строку
k = k + 1
sh.Range("a" & k).Offset(1).Resize(, 3).Value = _
Array(i, Dir(coll(i)), coll(i)) ' выводим на лист очередную строку
DoEvents ' временно передаём управление ОС
Next
sh.Range("a:c").EntireColumn.AutoFit ' автоподбор ширины столбцов
[a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
Call Secheniya
End Sub
99989
Оружие не убивает Человека! Человек убивает Человека!!!
