Тема родилась из очередного соревнования У меня есть готовая и надёжная функция (брал давно отсюда), основанная на FSO и использующая рекурсивный перебор, но мне дали понять, что есть варианты не менее надёжные, но гораздо более шустрые и основанные на библиотеке Shell32 (применить не смог - набросал только каркас макроса)
Для теста моего варианта, нажать синюю кнопку и выбрать папку
Код
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub PathsCollector()
Dim arr() As String, tx$, t!, r&
tx = ActiveWorkbook.Path
If Not FolderChoose(tx) Then Exit Sub
t = Timer
If Not GetPaths(tx, arr, r) Then Exit Sub
'ShellFilter tx
t = Timer - t
Columns(1).ClearContents
Cells(1, 1).Resize(r, 1).Value2 = arr
MsgBox "Paths found: " & Format$(r, "#,##0"), vbInformation, Format$(t, "0.0 sec")
End Sub
'====================================================================================================
Private Sub ShellFilter(FolderPath)
Dim iShell As Shell32.Shell, F As Shell32.Folder, FI As Shell32.FolderItems3, iFile As Shell32.FolderItem
Set F = iShell.Namespace(FolderPath)
Set FI = F.Items()
'FI.Filter 64 + 128, "*.xls;*.xlsx;*.xlsb;*.xlsm"
For Each iFile In FI
Debug.Print iFile.Path
Next iFile
End Sub
'====================================================================================================
Private Function GetPaths(FolderPath$, arr() As String, r&) As Boolean
Dim FSO As New FileSystemObject
ReDim arr(1 To 100000, 1 To 1)
RecurSearch FSO, arr, r, FolderPath
If r = 0 Then MsgBox "Paths NOT FOUND!", vbCritical, "GetPaths": Exit Function
GetPaths = True
End Function
'----------------------------------------------------------------------------------------------------
Private Sub RecurSearch(FSO As FileSystemObject, arr() As String, r&, FP$)
Dim curFol, iFile, sFol
Set curFol = FSO.GetFolder(FP)
If curFol.Files.Count Then
For Each iFile In curFol.Files
r = r + 1: arr(r, 1) = iFile.Path
Next iFile
End If
For Each sFol In curFol.SubFolders
RecurSearch FSO, arr, r, sFol.Path
Next sFol
Set iFile = Nothing: Set curFol = Nothing
End Sub
'====================================================================================================
'====================================================================================================
Private Function FolderChoose(ByRef tmpDefPath) As Boolean
Dim PS$
PS = Application.PathSeparator
If Not Right$(tmpDefPath, 1) = PS Then tmpDefPath = tmpDefPath & PS
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the FOLDER"
.ButtonName = "Folder choose"
.Filters.Clear
.InitialFileName = tmpDefPath
.InitialView = msoFileDialogViewDetails
If .Show = 0 Then Exit Function
PS = .SelectedItems(1)
If Len(PS) < 4 Then MsgBox "Can't search in Drive!" & vbLf & "Please, choose the FOLDER!", vbCritical, "FolderChoose": Exit Function
tmpDefPath = PS
End With
FolderChoose = True
End Function
'====================================================================================================
'====================================================================================================
Мой вариант у меня на компе получает список из 12 тыс файлов за 2,2 сек
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Здравствуйте. У меня есть готовое решение по этой теме. Источник основной функции тот же что и у Jack Famous. Я не претендую на какое-либо соревнование, просто предлагаю свой вариант с дополнительным функционалом(см. скриншот).
Код:
Код
Option Explicit
Private Sub btnSrart_Click()
Call FileList
End Sub
'Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' If CloseMode = 0 Then Cancel = True
'End Sub
Sub FileList()
Dim V As String, BrowseFolder As String
Application.ScreenUpdating = False
'открываем диалоговое окно выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку или диск"
.ButtonName = "Выбрать"
If .Show = 0 Then
Unload Me
Exit Sub
Else
V = .SelectedItems(1)
End If
End With
BrowseFolder = CStr(V) 'добавляем лист и выводим на него шапку таблицы
'ActiveWorkbook.Sheets.Add
Cells.Clear
With Range("A1:E1")
.Font.Bold = True
.Font.Size = 12
End With
Range("A1").Value = "Имя файла"
If CheckBoxFilePath Then Range("B1").Value = "Путь"
If CheckBoxFileSize Then Range("C1").Value = "Размер"
If CheckBoxDateCreated Then Range("D1").Value = "Дата создания"
If CheckBoxDateChange Then Range("E1").Value = "Дата изменения"
'вызываем процедуру вывода списка файлов
'измените True на False, если не нужно выводить файлы из вложенных папок
Call ListFilesInFolder(BrowseFolder, CheckBoxSubFolders.Value)
If CheckBoxFilePath.Value = False Then Columns("B").Delete
If CheckBoxFileSize.Value = False Then Columns("C").Delete
If CheckBoxDateCreated.Value = False Then Columns("D").Delete
If CheckBoxDateChange.Value = False Then Columns("E").Delete
Unload Me
End Sub
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object, SourceFolder As Object, SubFolder As Object, FileItem As Object, r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.getfolder(SourceFolderName)
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
'находим первую пустую строку
'выводим данные по файлу
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Name
If CheckBoxFilePath Then Cells(r, 2).Formula = FileItem.Path
If CheckBoxFileSize Then Cells(r, 3).Formula = FileItem.Size
If CheckBoxDateCreated Then Cells(r, 4).Formula = FileItem.DateCreated
If CheckBoxDateChange Then Cells(r, 5).Formula = FileItem.DateLastModified
If CheckBoxHiperLinkAdd Then HyperlinksAdd1 Cells(r, 1), FileItem.Path, Cells(r, 1).Text
r = r + 1
' X = SourceFolder.Path
Next FileItem
'вызываем процедуру повторно для каждой вложенной папки
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:E").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Sub HyperlinksAdd1(rAnchor As Range, sAddress As String, sTextToDisplay As String)
ActiveSheet.Hyperlinks.Add Anchor:=rAnchor, Address:=sAddress, TextToDisplay:=sTextToDisplay, ScreenTip:="Перейти к файлу"
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: (применить не смог - набросал только каркас макроса)
iShell As Shell32.Shell надо заменить на As New Shell32.Shell, но FI.Filter 64 + 128, "*. не работает, не рыскает во вложенных, как понял. Вложенные папки (в придачу с zip-ами) можно получть (32+128)