asesja Пользователь Сообщений: 320 |
Добрый вечер. |
Андрей VG Пользователь Сообщений: 11878 Excel 2016, 365 |
#2 07.11.2020 20:29:45 Доброе время суток.
Изменено: Андрей VG — 07.11.2020 20:30:16 |
||
Dmitriy XM Пользователь Сообщений: 333 |
#3 07.11.2020 20:47:55 Добрый день!
|
||
asesja Пользователь Сообщений: 320 |
#4 07.11.2020 20:51:42 Спасибо.
Изменено: asesja — 07.11.2020 20:53:44 |
||
БМВ Модератор Сообщений: 21378 Excel 2013, 2016 |
#5 07.11.2020 21:33:55
Изменено: БМВ — 07.11.2020 21:42:15 По вопросам из тем форума, личку не читаю. |
||
Андрей VG Пользователь Сообщений: 11878 Excel 2016, 365 |
Интересно, чем fso не угодил? Изменено: Андрей VG — 07.11.2020 21:42:14 |
asesja Пользователь Сообщений: 320 |
Всем огромное спасибо за помощь! Все предложенные варианты прекрасно работают. Изменено: asesja — 07.11.2020 21:54:25 |
у нас, на курсах трактористов, разрезали болгаркой жесткий диск Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете! |
|
vikttur Пользователь Сообщений: 47199 |
#9 07.11.2020 23:10:19
Диск от колеса БелАЗа? ) |
||
Андрей VG Пользователь Сообщений: 11878 Excel 2016, 365 |
#10 07.11.2020 23:49:59
Можно ещё и так
Объект Shell |
||||
Получение списка папок 1, 2 и 3 уровней вложенности с помощью кода VBA Excel. SubFolders — коллекция подпапок, расположенных в указанной папке.
Свойство SubFolders объекта Folder
SubFolders — это свойство объекта Folder, которое возвращает коллекцию подпапок, расположенных в указанной папке (Folder), включая скрытые и системные папки.
Обход папок разных уровней вложенности можно использовать не только для того, чтобы отобразить список папок на экране, но и для работы с находящимися в них файлами.
Список папок 1 уровня вложенности
Получение списка папок 1 уровня вложенности:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Sub ShowFolderSublevel1() Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, s As String ‘Указываем адрес исходной папки s = «C:Users» ‘Создаем экземпляр FileSystemObject Set fso = CreateObject(«Scripting.FileSystemObject») ‘Присваиваем переменной fo ссылку на указанную папку Set fo = fso.GetFolder(s) ‘Отключаем обработчик ошибок On Error Resume Next ‘Обходим циклом коллекцию подпапок в указанной папке For Each fo1 In fo.SubFolders ‘Печатаем полное имя текущей подпапки в окне Immediate Debug.Print fo1 ‘.Path — по умолчанию Next ‘Включаем обработчик ошибок On Error GoTo 0 End Sub |
Если в исходной папке нет подпапок, то применение свойства SubFolders вызовет ошибку. Чтобы пропускать такие ошибки, мы отключаем обработчик ошибок на время работы циклов.
Список папок 2 уровня вложенности
Получение списка папок 1 и 2 уровней вложенности:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
Sub ShowFolderSublevel2() Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, fo2 As Folder, s As String s = «C:Users» Set fso = CreateObject(«Scripting.FileSystemObject») Set fo = fso.GetFolder(s) On Error Resume Next ‘Обходим коллекцию подпапок 1 уровня вложенности For Each fo1 In fo.SubFolders Debug.Print fo1 ‘Обходим коллекцию подпапок 2 уровня вложенности For Each fo2 In fo1.SubFolders ‘Перед полным именем подпапки 2 уровня добавляем 4 пробела Debug.Print Space(4) & fo2 Next Next On Error GoTo 0 End Sub |
Список папок 3 уровня вложенности
Получение списка папок 1, 2 и 3 уровней вложенности:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
Sub ShowFolderSublevel3() Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, fo2 As Folder, fo3 As Folder, s As String s = «C:Users» Set fso = CreateObject(«Scripting.FileSystemObject») Set fo = fso.GetFolder(s) On Error Resume Next ‘Обходим коллекцию подпапок 1 уровня вложенности For Each fo1 In fo.SubFolders Debug.Print fo1 ‘Обходим коллекцию подпапок 2 уровня вложенности For Each fo2 In fo1.SubFolders ‘Перед полным именем подпапки 2 уровня добавляем 4 пробела Debug.Print Space(4) & fo2 ‘Обходим коллекцию подпапок 3 уровня вложенности For Each fo3 In fo2.SubFolders ‘Перед полным именем подпапки 3 уровня добавляем 8 пробелов Debug.Print Space(8) & fo3 Next Next Next On Error GoTo 0 End Sub |
Обратите внимание, если вы будете использовать для тестов папку «C:Users» как исходную, все строки с наименованиями подпапок в окне Immediate не уместятся (ограничение — 200 строк).
Как получить список файлов в папке, смотрите в статье VBA Excel. Список файлов в папке.
Фразы для контекстного поиска: вложенная папка, вложенные папки, список подпапок, обход подпапок, вывод списка.
Файлы к уроку:
- Для спонсоров Boosty
- Для спонсоров VK
- YouTube
- VK
Описание
Создадим макросы, которые выводят на листах Excel списки всех файлов в папке, папок и файлов внутри папок.
Решение
Список всех файлов внутри папки
' Перечень файлов внутри папки
Sub get_file_names()
Dim objFSO As Object ' В этой переменной будет объект FileSystemObject
Dim objFolder As Object ' В этой переменной будет объект Folder
' Получаем доступ к файловой системе компьютера
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Создаем объект Folder
Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
' Строка для вывода
row = 2
' Цикл по каждому файлу в папке
For Each file In objFolder.Files
' Имя файла
Cells(row, 1) = file.Name
' Путь к папке
Cells(row, 2) = objFolder
' Переход на следующую строку
row = row + 1
Next file
' Автоподбор ширины
Columns("A").EntireColumn.AutoFit
End Sub
Список всех папок внутри папки
' Перечень папок внутри папки
Sub get_subfolder_names()
Dim objFSO As Object
Dim objFolder As Object
' Получаем доступ к файловой системе компьютера
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Создаем объект Folder
Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
' Строка для вывода
row = 2
' Цикл по каждой папке в папке
For Each folder In objFolder.subfolders
' Вывод имени файла
Cells(row, 1) = folder.Name
' Путь к папке
Cells(row, 2) = folder.Path
' Переход на следующую строку
row = row + 1
Next folder
' Автоподбор ширины
Columns("A").EntireColumn.AutoFit
End Sub
Список всех файлов в папке, папок и файлов внутри папок
' Перечень папок и файлов внутри них
Sub get_subfolder_and_file_names()
Dim objFSO As Object
Dim objFolder As Object
' Получаем доступ к файловой системе компьютера
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Создаем объект Folder
Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
' Строка для вывода
row = 2
' Цикл по каждой папке
For Each subfolder In objFolder.subfolders
' Цикл по каждому файлу
For Each file In subfolder.Files
' Имя папки
Cells(row, 1) = subfolder.Name
' Имя файла
Cells(row, 2) = file.Name
' Путь к файлу/папке
Cells(row, 3) = file.Path
' Переход на следующую строчку
row = row + 1
Next file
Next subfolder
For Each file In objFolder.Files
' Имя папки
Cells(row, 1) = objFolder.Name
' Имя файла
Cells(row, 2) = file.Name
' Путь к файлу
Cells(row, 3) = file.Path
' Переход на следующую строчку
row = row + 1
Next file
End Sub
Примененные функции
- .GetFolder
- Cells
- CreateObject
- For Each
- Scripting.FileSystemObject
А что бы в список попали всякие с причудами директории, можно написать так —
Visual Basic | ||
|
Упсс: Это была добавка к четвёртому посту.
Добавлено через 31 минуту
Сообщение от Diskretor
Эту строку ‘If GetAttr(path & «» & D) And vbDirectory Then’ я, конечно, подсмотрел на MSDN, но нифига не понял зачем там ‘vbDirectory).
…она все равно выводит в т.ч. имена файлов.
На уровне подсознания я понимаю эту фишку, но сомневаюсь, сумею ли внятно объяснить
Но попробую-
Сообщение от F1
Dir[(pathname[, attributes])]
The attributes argument settings are:
Constant Value Description
vbNormal 0 (Default) Specifies files with no attributes.
vbReadOnly 1 Specifies read-only files in addition to files with no attributes.
vbHidden 2 Specifies hidden files in addition to files with no attributes.
VbSystem 4 Specifies system files in addition to files with no attributes
vbVolume 8 Specifies volume label; if any other attributed is specified, vbVolume is ignored
vbDirectory 16 Specifies directories or folders in addition to files with no attributes.
Dir ищет по сумме аттрибутов, поэтому 0 (vbNormal) на него не влияет, что бы ни указали в параметре attributes, поэтому и попадают в результат обычные (vbNormal) файлы.
А потому и необходима дополнительная фильтрация… Вот(уж как сумел)
Добавлено через 21 минуту
То есть
Visual Basic | ||
|
и
Visual Basic | ||
|
одно и тоже, с точки зрения Dir!
Добавлено через 6 минут
Сообщение от Diskretor
И еще вопрос: написано, что нужно ставить двойные кавычки Chr(34), если в имени папки есть пробелы. Но у меня все работает и без них. И наоборот ничего не выдает/работает неверно, если их указать.
Тоже с этим сталкивался неоднократно
Сделал вывод — для Dir это не нужно,
а для Shell и т.п. необходимо…
Вы когда-нибудь сталкивались с этой проблемой, когда перечисляли все папки и подпапки из указанного каталога на листе? В Excel нет быстрого и удобного способа получить имена всех папок в определенном каталоге сразу. Разобраться с этой задачей может вам эта статья.
Список всех папок и подпапок с кодом VBA
Список всех папок и подпапок с кодом VBA
Если вы хотите получить все имена папок из указанного каталога, следующий код VBA может вам помочь, сделайте следующее:
1. Удерживайте ALT + F11 ключи, и он открывает Окно Microsoft Visual Basic для приложений.
2. Нажмите Вставить > Модулии вставьте следующий код в Окно модуля.
Код VBA: список всех папок и имен вложенных папок
Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & ""
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld
End Sub
3, Затем нажмите F5 ключ для запуска этого кода и Выбрать папку появится всплывающее окно, затем вам нужно выбрать каталог, в котором вы хотите отобразить имена папок и подпапок, см. снимок экрана:
4. Нажмите OK, и вы получите путь к папке и подпапкам, каталог, имя, дату создания и дату последнего изменения в новой книге, см. снимок экрана:
Связанная статья:
Как перечислить файлы в каталоге на лист в Excel?
Лучшие инструменты для работы в офисе
Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%
- Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма …
- Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон…
- Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы… Предотвращение дублирования ячеек; Сравнить диапазоны…
- Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор …
- Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое …
- Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии…
- Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом …
- Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF…
- Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.
Вкладка Office: интерфейс с вкладками в Office и упрощение работы
- Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
- Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
- Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!
Комментарии (18)
Оценок пока нет. Оцените первым!
Данный макрос позволяет получить список папок, расположенных в выбранной папке (каталоге)
Если надо получить список папок, имена которых удовлетворяют определённому критерию, используйте маску поиска (параметр Mask$)
Код функции и пример использования:
Sub ПоискПодходящихПодпапок() ' считываем в колекцию coll подходящие полные пути папок ' (поиск папок с названием, начинающимся на 09) Set coll = SubFoldersCollection("d:", "09*") For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к папкам Debug.Print coll(i) ' выводим очередной путь в окно Immediate Next End Sub
Option Compare Text Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection Set SubFoldersCollection = New Collection ' создаём пустую коллекцию Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject If Right(FolderPath$, 1) <> "" Then FolderPath$ = FolderPath$ & "" On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$) For Each folder In curfold.SubFolders ' перебираем все подпапки в папке FolderPath If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Path & "" Next folder Set FSO = Nothing End Function
В этом примере та же функция используется для вывода названий подпапок на лист Excel:
Код немного изменён:
Option Compare Text Sub ЗагрузкаСпискаПодпапок() On Error Resume Next ' считываем в колекцию coll подходящие полные пути папок Set coll = SubFoldersCollection([b1], "*") ' путь к основной папке берем из ячейки B1 For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к папкам Cells(i + 2, 1) = coll(i) ' выводим очередное название папки на лист Next End Sub Sub Очистка() On Error Resume Next Range([A3], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp))).ClearContents End Sub Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection Set SubFoldersCollection = New Collection ' создаём пустую коллекцию Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject If Right(FolderPath$, 1) <> "" Then FolderPath$ = FolderPath$ & "" On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$) For Each folder In curfold.SubFolders ' перебираем все подпапки в папке FolderPath If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Name Next folder Set FSO = Nothing End Function
Расширенная версия функции — для поиска подпапок любого уровня вложенности:
Function FoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*", Optional ByVal SearchDeep& = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых папок Mask (будут отобраны только папки с подходящим именем) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути к найденным папкам ' (применяется рекурсивный вызов процедуры FindFolders) Set FoldersCollection = New Collection ' создаём пустую коллекцию FindFolders FolderPath, Mask, FoldersCollection, SearchDeep ' поиск End Function Function FindFolders(ByVal FolderPath$, ByVal Mask$, ByRef coll As Collection, ByVal SearchDeep&) ' перебирает все подпапки в папке FolderPath, используя объект FSO ' перебор подпапок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных папок в коллекцию coll Static FSO As Object: Dim current_folder As Object, folder As Object, subfolder As Object If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next: Set current_folder = FSO.GetFolder(FolderPath) If Not current_folder Is Nothing Then ' если удалось получить доступ к папке If current_folder.Name Like Mask Then coll.Add current_folder.Path & "" SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках For Each folder In current_folder.SubFolders ' перебираем все подпапки в папке FolderPath If folder.Name Like Mask Then coll.Add folder.Path & "" If SearchDeep Then ' если надо искать глубже For Each subfolder In folder.SubFolders ' перебираем все подпапки в очередной папке FindFolders subfolder.Path, Mask, coll, SearchDeep Next End If Next Set current_folder = Nothing: Set folder = Nothing: Set subfolder = Nothing End If End Function
пример использования:
Sub test_FoldersCollection() Dim coll As Collection, folder$ folder$ = "D:ПРОЕКТЫExcelПримеры" ' папка, в которой ищем подпапки ' получаем список подпапок с названием из 8 цифр Set coll = FoldersCollection(folder$, "########") ' выводим список найденных папок в окно Immediate For Each Item In coll Debug.Print Item Next End Sub
Updated July 2014: Added PowerShell
option and cut back the second code to list folders only
The methods below that run a full recursive process in place of FileSearch
which was deprecated in Office 2007. (The later two codes use Excel for output only — this output can be removed for running in Word)
- Shell
PowerShell
- Using
FSO
withDir
for filtering file type. Sourced from this EE answer which sits behind the EE paywall. This is longer than what you asked for (a list of folders) but i think it is useful as it gives you an array of results to work further with - Using
Dir
. This example comes from my answer I supplied on another site
1. Using PowerShell
to dump all folders below C:temp into a csv file
Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:tempfilename.csv", 1)
End Sub
2. Using FileScriptingObject
to dump all folders below C:temp into Excel
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:temp"
myArr = GetSubFolders(strPath)
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
Counter = Counter + 1
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
3 Using Dir
Option Explicit
Public StrArray()
Public lngCnt As Long
Public b_OS_XP As Boolean
Public Enum MP3Tags
' See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists
XP_Artist = 16
XP_AlbumTitle = 17
XP_SongTitle = 10
XP_TrackNumber = 19
XP_RecordingYear = 18
XP_Genre = 20
XP_Duration = 21
XP_BitRate = 22
Vista_W7_Artist = 13
Vista_W7_AlbumTitle = 14
Vista_W7_SongTitle = 21
Vista_W7_TrackNumber = 26
Vista_W7_RecordingYear = 15
Vista_W7_Genre = 16
Vista_W7_Duration = 17
Vista_W7_BitRate = 28
End Enum
Public Sub Main()
Dim objws
Dim objWMIService
Dim colOperatingSystems
Dim objOperatingSystem
Dim objFSO
Dim objFolder
Dim Wb As Workbook
Dim ws As Worksheet
Dim strobjFolderPath As String
Dim strOS As String
Dim strMyDoc As String
Dim strComputer As String
'Setup Application for the user
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'reset public variables
lngCnt = 0
ReDim StrArray(1 To 10, 1 To 1000)
' Use wscript to automatically locate the My Documents directory
Set objws = CreateObject("wscript.shell")
strMyDoc = objws.SpecialFolders("MyDocuments")
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & strComputer & "rootcimv2")
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem In colOperatingSystems
strOS = objOperatingSystem.Caption
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If InStr(strOS, "XP") Then
b_OS_XP = True
Else
b_OS_XP = False
End If
' Format output sheet
Set Wb = Workbooks.Add(1)
Set ws = Wb.Worksheets(1)
ws.[a1] = Now()
ws.[a2] = strOS
ws.[a3] = strMyDoc
ws.[a1:a3].HorizontalAlignment = xlLeft
ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate")
ws.Range([a1], [j4]).Font.Bold = True
ws.Rows(5).Select
ActiveWindow.FreezePanes = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strMyDoc)
' Start the code to gather the files
ShowSubFolders objFolder, True
ShowSubFolders objFolder, False
If lngCnt > 0 Then
' Finalise output
With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10))
.Value2 = Application.Transpose(StrArray)
.Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter
.Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit
End With
ws.[a1].Activate
Else
MsgBox "No files found!", vbCritical
Wb.Close False
End If
' tidy up
Set objFSO = Nothing
Set objws = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = vbNullString
End With
End Sub
Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)
Dim objShell
Dim objShellFolder
Dim objShellFolderItem
Dim colFolders
Dim objSubfolder
'strName must be a variant, as ParseName does not work with a string argument
Dim strFname
Set objShell = CreateObject("Shell.Application")
Set colFolders = objFolder.SubFolders
Application.StatusBar = "Processing " & objFolder.Path
If bRootFolder Then
Set objSubfolder = objFolder
GoTo OneTimeRoot
End If
For Each objSubfolder In colFolders
'check to see if root directory files are to be processed
OneTimeRoot:
strFname = Dir(objSubfolder.Path & "*.mp3")
Set objShellFolder = objShell.Namespace(objSubfolder.Path)
Do While Len(strFname) > 0
lngCnt = lngCnt + 1
If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))
Set objShellFolderItem = objShellFolder.ParseName(strFname)
StrArray(1, lngCnt) = objSubfolder
StrArray(2, lngCnt) = strFname
If b_OS_XP Then
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate)
Else
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate)
End If
strFname = Dir
Loop
If bRootFolder Then
bRootFolder = False
Exit Sub
End If
ShowSubFolders objSubfolder, False
Next
End Sub