Vba word список папок

А что бы в список попали всякие с причудами директории, можно написать так —

Visual Basic
1
2
3
4
D = Dir(path, vbDirectory Or vbHidden Or vbSystem)
While D <> ""
  If GetAttr(path & "" & D) And vbDirectory And D <> "."  And D <> ".." Then
  'далее по тексту

Упсс: Это была добавка к четвёртому посту.

Добавлено через 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
1
Dir(path, vbDirectory Or vbNormal)

и

Visual Basic
1
Dir(path, vbDirectory)

одно и тоже, с точки зрения Dir!

Добавлено через 6 минут

Цитата
Сообщение от Diskretor
Посмотреть сообщение

И еще вопрос: написано, что нужно ставить двойные кавычки Chr(34), если в имени папки есть пробелы. Но у меня все работает и без них. И наоборот ничего не выдает/работает неверно, если их указать.

Тоже с этим сталкивался неоднократно
Сделал вывод — для Dir это не нужно,
а для Shell и т.п. необходимо…

Файлы к уроку:

  • Для спонсоров 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

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)

  1. Shell PowerShell
  2. Using FSO with Dir 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
  3. 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

Получение списка папок 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. Список файлов в папке.


Фразы для контекстного поиска: вложенная папка, вложенные папки, список подпапок, обход подпапок, вывод списка.


 

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

Добрый вечер.
Подскажите, пож-та, как с помощью кода VBA на лист Excel в столбец «А» получить список только папок (без файлов) в заданном каталоге. В именах папок могут встречаться точки и различные символы.
Заданный каталог к примеру c:1
Содержание заданного каталога может быть различным. Нужны только имена папок.

 

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#2

07.11.2020 20:29:45

Доброе время суток.
Например, так

Код
Public Sub ShowFolderList()
    Dim pDialog As FileDialog, pFolder As Object
    Dim fso As Object, nextFolder As Object
    Dim folderNames() As String, i As Long
    Set pDialog = Application.FileDialog(msoFileDialogFolderPicker)
    pDialog.AllowMultiSelect = False
    If pDialog.Show Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set pFolder = fso.GetFolder(pDialog.SelectedItems(1))
        ReDim folderNames(1 To pFolder.SubFolders.Count)
        i = 0
        For Each nextFolder In pFolder.SubFolders
            i = i + 1
            folderNames(i) = nextFolder.Name
        Next
        MsgBox Join(folderNames, vbLf)
    End If
End Sub

Изменено: Андрей VG07.11.2020 20:30:16

 

Dmitriy XM

Пользователь

Сообщений: 333
Регистрация: 06.03.2013

#3

07.11.2020 20:47:55

Добрый день!

Код
Sub www()
Dim FSO As Object, fFolders As Object, fFolder As Object
Dim sFolderName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sFolderName = "D:Download"
Set fFolders = FSO.GetFolder(sFolderName)
For Each fFolder In fFolders.SubFolders
    x = x + 1
    Range("A" & x) = fFolder.Name
Next fFolder
End Sub
 

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

#4

07.11.2020 20:51:42

Спасибо.
Есть ли возможность решить эту задачу по другому, без использования FSO ?
У меня получается вывести список файлов и папок, либо только файлов. А вот получить имена только папок не знаю как.
Вот фрагмент моего простенького кода. Может кто-то подправит?

Код
pathDis = "c:1"
i = 1
J = 1
sPoisk = Dir(pathDis, vbDirectory)
Do While sPoisk <> ""
    If (Len(Trim(Replace(sPoisk, ".", ""))) > 0) Then
        Range("A" & J) = sPoisk
        J = J + 1
    End If
    sPoisk = Dir
Loop

Изменено: asesja07.11.2020 20:53:44

 

БМВ

Модератор

Сообщений: 21378
Регистрация: 28.12.2016

Excel 2013, 2016

#5

07.11.2020 21:33:55

Код
pathDis = "c:temp"
i = 1
J = 1
sPoisk = Dir(pathDis, vbDirectory)
Do While sPoisk <> ""
If (GetAttr(pathDis & sPoisk) And vbDirectory) = vbDirectory Then
    If (Len(Trim(Replace(sPoisk, ".", ""))) > 0) Then
        Range("A" & J) = sPoisk
        J = J + 1
    End If
End If
    sPoisk = Dir
Loop

Изменено: БМВ07.11.2020 21:42:15

По вопросам из тем форума, личку не читаю.

 

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

Интересно, чем fso не угодил?

Изменено: Андрей VG07.11.2020 21:42:14

 

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

Всем огромное спасибо за помощь! Все предложенные варианты прекрасно работают.
Андрей, с FSO тоже все замечательно получилось. Просто хотел узнать как можно сделать по другому.
Забираю в копилку.

Изменено: asesja07.11.2020 21:54:25

 

у нас, на курсах трактористов, разрезали болгаркой жесткий диск
и переписывали вручную содержимое нужной папки
смело ложите в копилку 3-й способ

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

#9

07.11.2020 23:10:19

Цитата
Ігор Гончаренко написал: …на курсах трактористов, разрезали болгаркой жесткий диск

Диск от колеса БелАЗа? )

 

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#10

07.11.2020 23:49:59

Цитата
asesja написал:
как можно сделать по другому

Можно ещё и так

Код
Public Sub ShowFolderList()
    Dim pDialog As FileDialog, pFolder As Object
    Dim pShell As Object, nextFolder As Object
    Dim pItems As Object
    Dim folderNames() As String, i As Long
    Set pDialog = Application.FileDialog(msoFileDialogFolderPicker)
    pDialog.AllowMultiSelect = False
    If pDialog.Show Then
        Set pShell = CreateObject("Shell.Application")
        Set pFolder = pShell.Namespace(pDialog.SelectedItems(1))
        Set pItems = pFolder.Items
        pItems.Filter 32, "*"
        ReDim folderNames(1 To pItems.Count)
        i = 0
        For Each pFolder In pItems
            i = i + 1
            folderNames(i) = pFolder.Name
        Next
        MsgBox Join(folderNames, vbLf)
    End If
End Sub

Объект Shell

Содержание

Введение
Работа с дисками и папками, путь
CurDir — текущая папка
ChDrive — смена логического диска
ChDir — смена папки
Dir — список файлов/папок
Name — переименование
MkDir — создание папки
RmDir — удаление папки
Kill — удаление файла
SetAttr — установка атрибутов


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Низкоуровневые функции
Идентификатор файла
Open #
Close #
Reset
Чтение и запись (общая сводка и принципы)
Write #
Print #
Spc
Tab #
Width #
Input #
Line Input #
Get #
Put #
Seek #
Примеры
Команды, операторы и функции в алфавитном порядке (низкоуровневые операторы помечены знаком #):
ChDrive,
ChDir,
Close #,
CurDir,
Dir,
FreeFile #,
Get #,
Input #,
Kill,
Line Input #,
MkDir,
Name,
Open #,
Print #,
Put #,
Reset #,
RmDir,
SetAttr,
Seek #,
Spc #,
Tab #,
Width #,
Write #

Одной из важнейших составляющих любого языка программирования является способность считывать и записывать информацию из файлов.
Стандартно это называется функциями низкого уровня (Low Level) и в полном объеме представлено в VBA.
Кстати, именно эта особенность и является основой опасности макросов.

С другой стороны, в свете изучаемого курса, нельзя не отметить, что обсуждаемые возможности относятся далеко не к начальному уровню.
Без них не удастся обойтись при автоматизации взаимодействия со сложной информацией из разнородных источников.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


P.S.! Завершение переработки материалов разработчика приводит к совершенно неутешительным выводам.
Материала по этой теме всегда было очень мало, да и качество оставляло желать лучшего.
Теперь же он стал «обструганным» под непонятный стандарт, разорванным в несвязанное словоизвержение и напичканным примерами,
половина из которых только запутывает ситуацию, а вторая — ничего не иллюстрирует.
Ну, или почти так.

Работа с файлами, дисками и папками, путь

Логика изложения основана на том, что можно сделать с существующими объектами, а уже потом — как создать новый.
Поскольку многие команды распространяются не только на работу с каталогами, но и на файлы, полное изложение приводится именно здесь.

Все, перечисленное здесь, не имеет прямого отношения к низкоуровневым функциям, но без этой информации работать нельзя в принципе.

Первым является вопрос о том, где мы сейчас находимся.
Совсем неочевиден не только ответ, но и то, что сам вопрос будет своевременно задан.
Данный тезис становится все более актуальным с каждым годом и мне не хотелось бы, чтобы мои ученики бились об него лбом.

CurDir

Определение текущей папки.

Синтаксис

CurDir [(диск)]

Из синтаксиса можно понять (или нет) достаточно многое.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Перечисленное не дает однозначного ответа на возникающие вопросы, но является основой для таковых.
Частичные решения есть в разделе Примеры.

ChDrive

Инструкция для смены текущего диска (ChDrive) работает довольно примитивно. Так, вариант

ChDrive «D»

определит текущим диском диск «D:». Из примера видно, что приводится только литерал, без двоеточия.

ChDir

Изменяет текущий каталог или текущую папку

Синтаксис

Chdir <путь>

Внимание! Изменяется текущая папка на указываемом диске, а не сам диск.
Для смены диска потребуется команда ChDrive.

В значении пути можно использовать обозначения относительного перемещения.
Например,


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Dir

Функция возвращает строку (String) с именем обнаруженных на диске файла, папки или подпапки.
Если объект файловой системы обнаружен не будет, возвратится пустая строка.

Синтаксис

Dir [(<путь>, [<атрибуты>])]

В имени можно использовать знаки подстановки маски файла (* и ?).

Передача в качестве аргумента пустой строки возвращает список всех файлов и папок.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Атрибуты (копия из справки)

Константа Значение Описание
vbNormal 0 Файлы без атрибутов (Значение по умолчанию.)
vbReadOnly 1 В дополнение к файлам без атрибутов определяет файлы, доступные только для чтения
vbHidden 2 В дополнение к файлам без атрибутов определяет скрытые файлы
vbSystem 4 В дополнение к файлам без атрибутов определяет системные файлы
vbVolume 8 Определяет метку тома, то есть имя логического диска (не букву!). Если указан какой-либо другой атрибут, параметр vbVolume игнорируется
vbDirectory 16 В дополнение к файлам без атрибутов определяет каталоги (папки)

Из контекста описания понятно, что атрибуты могут суммироваться.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Name

Оператор Name переименовывает файл или папку и/или перемещает их в новое место.

Синтаксис

Name <oldpathname> As <newpathname>

При этом

  • Обрабатываются только уже существующие объекты.
  • Файл может быть перемещен на другой диск.
  • Файлы, открытые низкоуровневыми процедурами, надо предварительно закрыть.
  • Перемещение папок и подпапок возможно только в пределах логического диска.

MkDir

Создает новый каталог или папку.

Синтаксис

Mkdir <путь>

Если диск не указан, новые каталог или папка создаются на текущем диске.
Имя присваивается с учетом регистра символов.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


RmDir

Удаляет существующую директорию или папку.

Синтаксис

RmDir <путь>

Невозможно удалить папку, содержащую файлы, так что следует вначале удалить их, используя команду Kill.
Также этой командой нельзя удалить файл.

Kill

Удаляет файлы с диска.

Синтаксис

Kill <путь>

В качестве пути указывается строка, содержащая имя одного или нескольких файлов, предполагаемых к удалению.
Строка может содержать любой фрагмент пути, начиная от логического диска, то есть относительный или абсолютный.

В имени можно использовать знаки подстановки маски файла (* и ?).

Так как команда удаляет только файлы, для удаления папок следует воспользоваться командой RmDir.

SetAttr

Устанавливает атрибуты файла.

Синтаксис

SetAttr <имя файла>, <атрибуты>

Оба параметра являются обязательными. Имя файла может содержать путь.

Нельзя изменять атрибуты у открытых файлов!

Атрибуты:

Константа Значение Описание
vbNormal 0 Без атрибутов (по умолчанию)
vbReadOnly 1 Только для чтения (Read-only)
vbHidden 2 Скрытый файл (Hidden)
vbSystem 4 Системный файл (System)
vbArchive 32 Файл изменен после последнего резервного копирования

Атрибуты при указании могут суммироваться.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Низкоуровневые функции

Рассуждая здраво, практически невозможно сформировать однозначную последовательность изложения, так как тогда мы упремся в проблему яйца и курицы.
Даже понимание того, что прежде чем считывать файл, он должен быть создан не очень помогает: чтение выполняется намного чаще.

Идентификатор файла

Основным моментом для работы с обсуждаемым функционалом является то, что каждому файлу, над которым производятся действия, обязан быть присвоен целочисленный идентификатор (FileNumber) типа Byte.
Таким образом, может быть открыто до 511 файлов (1–511). По умолчанию используется лишь 255.
Все обращения к файлам (чтение и запись) производятся только(!) через идентификатор, предваряемый знаком диеза, например, #1.

Его должен задать программист, но делать это вручную допустимо только для простых ситуаций. Лучше воспользоваться следующей функцией

FreeFile [(RangeNumber)]

где RangeNumber — 0 (1–255) или 2 (256–511).

Простейший вариант обращения (запроса) к функции выглядит так:

MyFileNum = FreeFile

Далее по тексту будет использоваться именно выделенная красным переменная, содержащая получаемый ID (для упрощения записи).
Если не будет заявлено другое или использовано явное указание.

И еще раз, для более четкого понимания. В небольших проектах и программах будет более чем оправдано непосредственное указание идентификатора в командах: #1, #2…

Команда Open #

Открывает файл для операций ввода/вывода (input/output, I/O).

Синтаксис

Open <имя файла> For <mode> [Access <вид доступа>] [<lock>] As [#]FileNumber [Len = <RecLength>]

Здесь имя файла определяет имя, которое может содержать путь;
mode указывает режим открытия файла: Append (добавление), Binary (двоичный), Input (чтение), Output (запись) либо Random (случайный) (см. ниже);
Access определяет вид доступа: Read (чтение), Write (запись), Read Write (чтение и запись);
lock ключевое слово, определяющее доступность файла для других процессов: Shared, Lock Read, Lock Write или Lock Read Write;
[#]FileNumber заменяется на числовой идентификатор файла, используемый для последующей работы функций.
Len определяет размер записи (≤32767 (байт)), необходимый для внесения информации в файл с помощью Put #.

Если указываемый на запись файл отсутствует, то он будет создан.
Естественно, попытка чтения несуществующего файла закончится ошибкой (см. Dir).

Описание команды упрощено!

Команда Close #

После завершения работы файл должен быть закрыт. Иначе какой-либо доступ к нему может быть заблокирован (в примитивном понимании и без дополнительного обсуждения).
Для этого используется следующая команда:

Close [FileNumberList]

В качестве параметра передается номер файла, номера файлов через запятую или ничего. В последнем случае закроются все открытые файлы.

Примеры

	Close ' Закрыть все открытые файлы
	Close #1 ' Закрыть файл с идентификатором #1
	Close #1, #7 ' Закрыть два файла (с идентификаторами #1 и #7)
	Close #ProjID ' Закрыть файл с идентификатором, сохраненным в переменной памяти ProjID

См. также Reset.

Reset

Закрывает все файлы, открытые с помощью оператора Open, записывая содержимое их буферов на диск.

По существу, дублирует команду Close без атрибутов.

Чтение и запись

Как уже сказано выше, команда Open # позволяет открыть файл для использования в разных режимах, которые можно разделить на три группы.

  • Последовательный (Sequential) доступ (режимы Input, Output и Append) используется для записи в текстовые файлы, например, журналы ошибок и отчеты.
  • Прямой или произвольный доступ (Random) используется для считывания и записи данных в файле без его закрытия.
    Файлы с прямым доступом сохраняются данные в записях, что ускоряет нахождение требуемой информации.
  • Двоичный доступ (режим Binary) используется для считывания или записи любого байта в файле, например, при сохранении или отображении растрового рисунка.

Сводка стандартных операторов, используемых для чтения и записи в разных режимах.

Тип доступа Запись данных Чтение данных
Последовательный (Sequential) Print #, Write # Input #
Произвольный (Random) Put Get
Двоичный (Binary) Put Get

Write #

Записывает данные в последовательный файл в структурированном виде.

Синтаксис

Write #FileNumber, [OutputList]

Необязательный параметр OutputList представляет одно или несколько числовых, или строковых выражений через запятую, которые нужно записать в файл.
В переводе на обыденный язык, каждая строка подобного результирующего файла является перечнем значений с разделителем, каждое из которых записано по строгим правилам.
Фактически мы получаем известный большинству CSV-файл.
Чтобы не возникало неожиданностей при считывании, следует очень четко придерживаться правил.

Отсутствие OutputList (запятая в команде остается!) приводит к записи пустой строки.

Некоторые важные правила и особенности:

  • В качестве разделителя в outputlist можно использовать пробел, точку с запятой или запятую.
    По очень многим соображениям настоятельно рекомендую использовать только точку с запятой.
  • Числовые данные всегда записываются с помощью точки в качестве разделителя целой и дробной части.
  • Вся информация записывается в особом виде, зависящем от типа данных и знание об этом создает довольно серьезную путаницу.
    Важно четко разделить информацию и понимать, что OutputList записывается в формате VBA.
    Никакие последующие «причуды форматирования» нас не касаются.
    Знать их нужно, чтобы находить и исправлять ошибки, либо для вывода информации, условно говоря, вручную.
    То есть без помощи, которую нам предоставляет функция Write #.
  • Из предыдущего тезиса неизбежно вытекает, что некоторые данные проще выводить, предварительно записав их значение в переменную.
    Например, дату или код ошибки.
    Естественным образом это складывается для информации, получаемой посредством вычислений.
  • Сохранение (запись) данных:
      Строка — заключается в кавычки
      Число — цифры без кавычек
      Логические — #FALSE# и #TRUE#
      Null — #FALSE# и #TRUE#
      Дата — в универсальном формате даты
      Ошибка — #ERROR ErrorCode#, где ErrorCode является соответствующим номером
  • Нельзя использовать строки, уже содержащие в себе кавычки.
  • В конец файла (после записи последнего символа) будет вставлен символ новой строки (Chr(13) + Chr(10)).

Примеры (все данные записываются в ранее открытый файл с идентификатором #1)

   Write #1, 'Запись пустой строки
   Write #1, False; True 'Запись истинного и ложного значений
   Write #1, Tr(1); Tr(2); Tr(3) 'Запись значений трех последовательных элементов массива
   Write #1, Now; 128; True; "Текст"; MyVar 'Запись разнородных значений

Данные, записанные с помощью Write #, обычно считываются из файла с помощью оператора Input #.
Именно во взаимодействии этой пары и заключен весь смысл.

В подобном файле крайне удобно хранить настройки для работы проекта, которые пользователь может изменить в соответствии со своими потребностями.
Для передачи подобных макросов на сторону следует предусматривать (встраивать) возможности восстановления файлов, если пользователь их удалит или отредактирует вручную.

С другой стороны, набор множества таких строк представляет собой своего рода таблицу базы данных.

Print #

Записывает отформатированные данные в последовательный файл.

Синтаксис

Print #FileNumber, [OutputList]

OutputList — выражение или список выражений, которые необходимо вывести.

Его синтаксис

[{Spc(n) | Tab [(n)]}] [выражение] [позиция]

См. Spc #, Tab #, а также Width #.
Выражение может быть числовым или строковым, «позиция» определяет столбец, где будет начало вывода.

С учетом специфического применения оператора, детали его действия опущены.

Spc

Функция используется с оператором Print # или методом Print для позиционирования выходных данных. Аналог Space().

Синтаксис

Spc(n)

Параметр n указывает, сколько пробелов будет возвращено. При переполнении строки, излишек переходит на следующую.

Если не умничать, то функция будет работать только с моноширинным шрифтом.

Пример

	Print #1, "Последующий текст начнется через 10 пробелов"; Spc(10); "вот он!"

Tab #

Используется с оператором Print # или методом Print для позиционирования выходных данных.

Синтаксис

Tab[(n)]

Вставляет табулятор. Если параметр не указан, печать смещается к следующей позиции (шаг равен 14 символам).
Наличие параметра перемещает к позиции с указанным номером. А если она уже была, то на эту позицию, но следующей строки.

Ширина (длина строки) определяется значением Width #.

Width #

Оператор Width # назначает ширину строки вывода для файла, открытого с помощью оператора Open #.

Синтаксис

Width #FileNumber, width

Если значение width равно 0, длина строки является неограниченной. Оно используется по умолчанию.

Input #

Читает строку со структурированными данными из открытого последовательного файла и сохраняет эти данные в переменных.

Синтаксис

Input #FileNumber, VarList

Обычно данная инструкция считывает файлы, созданные посредством Write #.
Использовать ее следует только с файлами, открытыми в режиме Input или Binary.

Параметр VarList представляет собой перечисленный список переменных, в которые сохраняются считываемые данные.

Примеры

	Input #2, Var1, Var2, Var3

Line Input #

Считывает одну строку из открытого последовательного файла и присваивает ее переменной типа String или Variant.

Синтаксис

Line Input #FileNumber, VarName

Оператор следует отнести к самому востребованному варианту считывания данных из файла.
Считанная строка может быть подвергнута любой обработке.

Get #

Считывает данные из открытого файла на диске в переменную.

Синтаксис

Get [#]FileNumber, [RecNumber], VarName

Необязательный параметр RecNumber типа Variant (Long) указывает на номер записи (для файлов, открытых в режиме Random)
или байтовое число (для файлов, открытых в режиме Binary), с которого начинается считывание. При его отсутствии, запятая сохраняется
Результат сохраняется в переменную VarName.

Длинное и глупое описание работы функции можно свести к следующему.

  1. Читаем описание Put #.
  2. Если вы не знаете длину записи (Len), то не сможете правильно открыть файл и, как следствие, правильно прочитать его.
    Единственным адекватным выходом будет анализ исходного файла «глазами».

Данные, для считывания с помощью Get, обычно записываются в файл с помощью Put #.

Примеры

	Get #4,,BufferVar

Put #

Записывает данные из переменной в файл на диске.

Синтаксис

Put [#]FileNumber, [RecNumber], VarName

Необязательный параметр RecNumber типа Variant (Long) указывает на номер записи (для файлов, открытых в режиме Random)
или байтовое число (для файлов, открытых в режиме Binary), с которого начинается запись.
Если его не использовать, то производится запись следующего номера, после последнего, определенного обращением к любому из операторов
Get #, Put или Seek #.

Особенности для файлов, открытых в режиме Random:

  1. Параметр Len, задаваемый при открытии файла, играет ключевую роль.
    Во-первых, длина записи не может его превышать.
    Во-вторых, если запись меньше, то она дополняется пробелами до размера Len.
  2. Если записываемая переменная является строкой переменной длины, оператор Put записывает 2-байтовый дескриптор c длиной строки, а затем переменную.
    То есть длина записи, указанная предложением Len в операторе Open, должна быть по крайней мере на 2 больше, чем фактическая длина строки записываемых данных.
  3. Если записываемая переменная имеет числовой подтип Variant, оператор Put записывает дополнительно 2 байта, указывающие на тип. См. п.2.
  4. Если записываемая переменная имеет строковый подтип Variant, оператор Put записывает дополнительно 2 байта, указывающие на тип и еще 2 — на длину.
    Соответственно, значение Len должно быть увеличено на 4.
  5. Если записываемая переменная является динамическим массивом пользовательского типа, Put записывает дескриптор, длина которого равна 2 плюс в 8 раз больше числа измерений,
    то есть 2 + 8 * число измерений. То есть, для одномерного массива — 10 (2+8*1), для двумерного — 18 (2+8*2) и т.д.
    Плюс размер массива, описать который нормально сотрудники Microsoft не удосужились.
  6. Если записываемая переменная является массивом фиксированного размера, оператор Put записывает только данные, без дескриптора.
  7. При любом другом типе переменной все также, как и в п.6.

Особенности для файлов, открытых в режиме Binary (в дополнение к особенностям Random):

  • Параметр Len, задаваемый при открытии, не действует. Значения переменных записываются последовательно, без заполнителя.
  • Для любого другого массива, чем массив типа, определяемого пользователем, оператор Put записывает только данные, без дескриптора.
  • Оператор Put записывает строки переменной длины, не являющиеся элементами типов, определяемых пользователем, с числом байтов равных числу знаков в строке.

Данные, записанные с помощью Put, обычно считываются из файла с помощью Get #.

Seek #

Задает положение следующей операции чтения/записи в файле, открытом с помощью оператора Open #.

Синтаксис

Seek [#]FileNumber, position

Параметр position указывает начальную точку чтения и должен располагаться в диапазоне 1—2 147 483 647.

Его работа тесно связана с использованием Get # и Put #.

По существу, оператор назван неудачно, так как ничего не ищет, а просто перемещается по команде.

Примеры

Содержание
Создание файла
Проверка существования файла
Запись информации в новый файл
Добавление информации в существующий файл
Построчное считывание файла
Назначение текущей папки

Здесь не стоит разговаривать о микроскопических программах, хотя из приводимых примеров можно извлекать блоки и использовать их в качестве заготовок.

Также не будет полноценных примеров для бездумного копирования.

Многие ситуации содержат схожие требования, но идеальное решение должно состоять из множества функций.
Сейчас их делать не очень хочется, но это запланировано в перспективе.

В любом случае, все примеры полностью работоспособны.

Принципиально важен факт документирования функции с точки зрения возвращаемых значений.
Равно как и описание передаваемых параметров.

Для большинства представляемых примеров используются следующие положения, если не указано иное.

  • Путь должен содержать литерал диска (C:…).
  • Путь не должен заканчиваться косой чертой: «C:ab».
  • Если путь и файл передаются отдельно, то имя файла не должно содержать пути.
  • Все параметры являются обязательными и не могут быть пустыми. Последнее обстоятельство не проверяется.

Создание файла

Данное действие специально вынесено в отдельный заголовок, так как будет базовым для примеров, когда файла ещё нет.
Оно имеет множество особенностей, включая фатальные для хранящейся информации.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Ещё один момент. Добавим программу (фрагмент), которая будет запускать процесс.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Проверка существования файла

Имеет прикладное назначение не только в случае использования низкоуровневых функций.
По существу, нужно в любом программном проекте в качестве условия его запуска.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


Запись информации в новый файл

Разумеется, что в этой ситуации файл нужно не открыть, а создать.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


….

Добавление информации в существующий файл

Казалось бы…
Но первым действием должна быть проверка его наличия, если это не было сделано в программе ранее.


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


….

Построчное считывание файла


Доступ к этим материалам предоставляется только зарегистри­рован­ным пользователям!


….

Назначение текущей папки

Если работа с проектами так или иначе связана с файлами, хранящимися в одной папке, самым простым вариантом будет назначение ее текущей.

Представленный пример имеет формат глобальной функции (доступной для любого проекта), производящей множество проверок.


Доступ к размещенным в этом месте материалам ограничен и предоставляется следующим категориям:
1. Студент I/II курса ВХК РАН. 2. Бывший студент ВХК РАН. 3. Подготовка к ОГЭ. 4. Подготовка к ЕГЭ. 5. VIP-пользователь. 6. Благотворитель.


В принципе, возможна как оптимизация программы, так и ее модернизация или приспособление для других нужд.

Skip to content

VBA List Folders Subfolders in Directory

  • VBA List Folders Subfolders in a Directory

Objective: VBA List Folders Subfolders in a Directory helps you to list or find all folders and Subfolders from a Directory. You can list all details of Folders in a Worksheet. So that we can easily have an eye on all the details related to Folders and Subfolders. It includes Folder property details like complete path, short path, folder name, short folder name, file size, folder create date, number of Subfolders, number of files in a Subfolder etc.

  • How we are going to develop this project(The KEY steps)
  • Code and Explanation for each Procedure and Function
  • Final VBA Module (Code/Macro)
  • Assign macro to a Shape on the Worksheet
  • Instructions to Execute the Project
  • Download the Project Workbook – Excel Macro File

VBA List Folders Subfolders in Directory: Project Approach

To List Folders Subfolders in Excel Workbook, minimum one worksheet should be exist (Note: Please keep it in mind workbook always contains minimum worksheet. We can’t delete all worksheets from a workbook). Let me explain the key steps to develop this folders and Subfolders details in a Worksheet project. We are going to write two procedures (sbListAllFolderDetails and sbListAllFolders) and one function (sbBrowesFolder) in one module. Please find step by step instructions to List Folders Subfolders from Directory.

  • Step 1: TurnOff screen update and Events: We are temporarily avoiding screen flickering and events triggering in the application.
  • Step 2: Variable Declaration: We will be declaring required variables and objects which are using in our procedures and function.
  • Step 3: Browse Main folder (Directory): We will browse and select root folder list folders and sub folders from Directory.
  • Step 4: Delete old ‘Folder Details’ Worksheet: Before creating new ‘Folder Details’ Worksheet, we have to check if there is any existing Worksheet with the same name and delete it.
  • Step 5: Add new ‘Folder Details’ Worksheet: Lets add new worksheet, named it as ‘Folder Details’.
  • Step 6: Create Title and Headers : Here we will create main title and headers and then will do formatting to Main title and headers.
  • Step 7: Calling Sub Procedure from Main Procedure: Here we call Sub Procedure to list folders and sub folder details in Worksheet.
  • Step 8: TurnOn screen update and Events: Let’s reset the screen update and events of application.

List Folders Subfolders :Code and explanation for each control

Here is the detailed VBA Code/Macro/Procedure explanation. We are creating two procedures here. The first procedure name is ‘sbListAllFolderDetails’. Now we will discuss about first procedure.

Step 1: Disable Screen Updating is used to stop screen flickering and Disable Events is used to avoid interrupted dialog boxes or popups.

'Disable screen update
Application.ScreenUpdating = False

Step 2: Declaring variables which are using in the entire project.

'Variable Declaration
Dim shtFldDetails As Worksheet
Dim sRootFolderName As String

Step 3: Browse Main Folder or Directory Folder

This VBA code prompts the user to browse for a folder. You can select folder to list files and Subfolder from Directory. Now click on Ok button to continue process. If you click on cancel button, It will display message like “Please select folder to find list of folders and Subfolders” and exit from the Procedure.

'Browse Root Folder
    sRootFolderName = sbBrowesFolder & ""
    
    'If path is not available, it display message and exit from the procedure
    If sRootFolderName = "" Then
        MsgBox "Please select folder to find list of folders and Subfolders", vbInformation, "Input Required!"
        Exit Sub
    End If

Function to Browse Folder:

Here is the function to browse Directory folder.

Public Function sbBrowesFolder()
    Dim FldrPicker As FileDialog
    Dim myPath As String
        
    'Browse Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
      With FldrPicker
        .Title = "Browse Root Folder Path"
        .AllowMultiSelect = False
          If .Show <> -1 Then Exit Function
          myPath = .SelectedItems(1)
      End With
 
      sbBrowesFolder = myPath
      If myPath = vbNullString Then Exit Function

End Function

Step 4: Deleting the ‘Folder Details’ Worksheet if it exists in the Workbook. And Display Alerts is used to stop pop-ups while deleting Worksheet.

Check if any worksheet is exit with name ‘Folder Details’. If it exists, delete sheet using delete method.

    'Delete Sheet if it exists
    Application.DisplayAlerts = False
        On Error Resume Next
        ActiveWorkbook.Sheets("Folder Details").Delete
    Application.DisplayAlerts = True

Step 5: Adding a new WorkSheet at the end of the Worksheet. Naming as ‘Folder Details’. And finally it is assigned it to an object (shtFldDetails).

    'Add new Worksheet and name it as 'Folder Details'
    With ThisWorkbook
        Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        shtFldDetails.Name = "Folder Details"
    End With

    'Create object for sheet name
    Set shtFldDetails = Sheets("Folder Details")

Step 6: Create Main Title and Headers

Here we are creating Main Title as ‘Folder and Subfolder details’. Creating header titles and applying format to it. So that it looks neat and clean.

'Main Header and its Format
    With shtFldDetails.Range("A1")
        .Value = "Folder and SubFolder Details"
        .Font.Bold = True
        .Font.Size = 12
        .Interior.ThemeColor = xlThemeColorDark2
        .Font.Size = 14
        .HorizontalAlignment = xlCenter
    End With
    
    With shtFldDetails
        'Merge Header cells
        .Range("A1:H1").Merge
    
        'Create Headers
        .Range("A2") = "Folder Path"
        .Range("B2") = "Short Folder Path"
        .Range("C2") = "Folder Name"
        .Range("D2") = "Short Folder Name"
        .Range("E2") = "Number of Subfolders"
        .Range("F2") = "Number of Files"
        .Range("G2") = "Folder Size"
        .Range("H2") = "Folder Create Date"
        
        .Range("A2:H2").Font.Bold = True
    End With

Step 7: Call Sub Procedure from Main Procedure

The below called sub procedure lists all the details of folders & sub folders. It then uses recursive procedure to loop through all folders and subfolders and the list its properties of folder and it captures all those details to a new Excel sheet called “Folder Details”.

    'Call Sub Procedure
    'List all folders & subfolders
    sbListAllFolders sRootFolderName

Sub Procedure : sbListAllFolders

The second sub procedure name is ‘sbListAllFolders’. Now we will discuss about this second sub procedure which is used in main module.

Sub sbListAllFolders(ByVal SourceFolder As String)
    
    'Variable Declaration
    Dim oFSO As Object, oSourceFolder As Object, oSubFolder As Object
    Dim iLstRow As Integer
            
    'Create object to FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = oFSO.GetFolder(SourceFolder)
    
    'Define Start Row
    iLstRow = Sheets("Folder Details").Cells(Sheets("Folder Details").Rows.Count, "A").End(xlUp).Row + 1
    
    'Update Folder properties to Sheet
    With Sheets("Folder Details")
        .Range("A" & iLstRow) = oSourceFolder.Path
        .Range("B" & iLstRow) = oSourceFolder.ShortPath
        .Range("C" & iLstRow) = oSourceFolder.Name
        .Range("D" & iLstRow) = oSourceFolder.ShortName
        .Range("E" & iLstRow) = oSourceFolder.SubFolders.Count
        .Range("F" & iLstRow) = oSourceFolder.Files.Count
        .Range("G" & iLstRow) = oSourceFolder.Size
        .Range("H" & iLstRow) = oSourceFolder.datecreated
    End With
        
    'Loop through all Sub folders
    For Each oSubFolder In oSourceFolder.SubFolders
        sbListAllFolders oSubFolder.Path
    Next oSubFolder
    
    'Autofit content in respective columns
    Sheets("Folder Details").Columns("A:H").AutoFit
    
    'Release Objects
    Set oSubFolder = Nothing
    Set oSourceFolder = Nothing
    Set oFSO = Nothing

End Sub

Step 8: Enabling or TurnOn Screen Update and Events at the end of the project.

   'Enable Screen Update
    Application.ScreenUpdating = True

List Folders Subfolders :Final VBA Module Code(Macro):

Please find the following procedures and Function to List Folders Subfolders project.

First Main Procedure

Option Explicit

Sub sbListAllFolderDetails()
    
    'Disable screen update
    Application.ScreenUpdating = False
    
    'Variable Declaration
    Dim shtFldDetails As Worksheet
    Dim sRootFolderName As String
    
    'Browse Root Folder
    sRootFolderName = sbBrowesFolder & ""
    
    'If path is not available, it display message and exit from the procedure
    If sRootFolderName = "" Then
        MsgBox "Please select folder to find list of folders and Subfolders", vbInformation, "Input Required!"
        Exit Sub
    End If
    
    'Delete Sheet if it exists
    Application.DisplayAlerts = False
        On Error Resume Next
        ActiveWorkbook.Sheets("Folder Details").Delete
    Application.DisplayAlerts = True
    
    'Add new Worksheet and name it as 'Folder Details'
    With ThisWorkbook
        Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        shtFldDetails.Name = "Folder Details"
    End With
    
    'Create object for sheet name
    Set shtFldDetails = Sheets("Folder Details")
    
    'Clear Sheet
    shtFldDetails.Cells.Clear
    
    'Main Header and its Format
    With shtFldDetails.Range("A1")
        .Value = "Folder and SubFolder Details"
        .Font.Bold = True
        .Font.Size = 12
        .Interior.ThemeColor = xlThemeColorDark2
        .Font.Size = 14
        .HorizontalAlignment = xlCenter
    End With
    
    With shtFldDetails
        'Merge Header cells
        .Range("A1:H1").Merge
    
        'Create Headers
        .Range("A2") = "Folder Path"
        .Range("B2") = "Short Folder Path"
        .Range("C2") = "Folder Name"
        .Range("D2") = "Short Folder Name"
        .Range("E2") = "Number of Subfolders"
        .Range("F2") = "Number of Files"
        .Range("G2") = "Folder Size"
        .Range("H2") = "Folder Create Date"
        
        .Range("A2:H2").Font.Bold = True
    End With
     
    'Call Sub Procedure
    'List all folders & subfolders
    sbListAllFolders sRootFolderName
    
    'Enable Screen Update
    Application.ScreenUpdating = True
    
End Sub

Second Sub Procedure used in Main Module

Sub sbListAllFolders(ByVal SourceFolder As String)
    
    'Variable Declaration
    Dim oFSO As Object, oSourceFolder As Object, oSubFolder As Object
    Dim iLstRow As Integer
            
    'Create object to FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = oFSO.GetFolder(SourceFolder)
    
    'Define Start Row
    iLstRow = Sheets("Folder Details").Cells(Sheets("Folder Details").Rows.Count, "A").End(xlUp).Row + 1
    
    'Update Folder properties to Sheet
    With Sheets("Folder Details")
        .Range("A" & iLstRow) = oSourceFolder.Path
        .Range("B" & iLstRow) = oSourceFolder.ShortPath
        .Range("C" & iLstRow) = oSourceFolder.Name
        .Range("D" & iLstRow) = oSourceFolder.ShortName
        .Range("E" & iLstRow) = oSourceFolder.SubFolders.Count
        .Range("F" & iLstRow) = oSourceFolder.Files.Count
        .Range("G" & iLstRow) = oSourceFolder.Size
        .Range("H" & iLstRow) = oSourceFolder.datecreated
    End With
        
    'Loop through all Sub folders
    For Each oSubFolder In oSourceFolder.SubFolders
        sbListAllFolders oSubFolder.Path
    Next oSubFolder
    
    'Autofit content in respective columns
    Sheets("Folder Details").Columns("A:H").AutoFit
    
    'Release Objects
    Set oSubFolder = Nothing
    Set oSourceFolder = Nothing
    Set oFSO = Nothing


End Sub

Function to Browse Folder

Public Function sbBrowesFolder()
    Dim FldrPicker As FileDialog
    Dim myPath As String
        
    'Browse Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
      With FldrPicker
        .Title = "Browse Root Folder Path"
        .AllowMultiSelect = False
          If .Show <> -1 Then Exit Function
          myPath = .SelectedItems(1)
      End With
 
      sbBrowesFolder = myPath
      If myPath = vbNullString Then Exit Function

End Function

Assign List Folders and Sub Folders from Directory macro to a Shape on the Worksheet:

Here are steps to create above specified project in the workbook.

  1. Place any shape by clicking on insert menu from illustrations group.
  2. Right click on the shape, select assign macro.
  3. select the macro name(‘sbListAllFolderDetails’) from the available list and click on OK button.
  4. Now, go to the Developer tab.
  5. Design Mode should be turned off from the Controls group.
  6. Now, go back to the shape and click on the created shape to see the TOC Worksheet in the Workbook.

List Folders Subfolders Project:Instructions to Execute the Procedure

You can download the below file and see the code and execute it. Or else, you create new workbook and use the above code and test it. Here are the instructions to use above code.

  1. Open VBA Editor window or Press Alt+F11.
  2. Insert a new module from the Insert menu.
  3. Copy the above procedure and paste it in the newly created module.
  4. You can hit F5 key from the keyboard and you can see the ‘Folder Details’ Worksheet at the end of all Worksheets in the workbook.

Download List Folders SubFolders from Directory – Excel VBA Project:

Here is the project workbook macro file to explore yourself.

VBA to List Folders and Subfolders in a Directory

Related articles about files and folders:

Please find below link to read more details about files and folders.
Files and Folders: Read More …

Effortlessly Manage Your Projects and Resources
120+ Professional Project Management Templates!

A Powerful & Multi-purpose Templates for project management. Now seamlessly manage your projects, tasks, meetings, presentations, teams, customers, stakeholders and time. This page describes all the amazing new features and options that come with our premium templates.

Save Up to 85% LIMITED TIME OFFER
Excel VBA Project Management Templates
All-in-One Pack
120+ Project Management Templates
Essential Pack
50+ Project Management Templates

Excel Pack
50+ Excel PM Templates

PowerPoint Pack
50+ Excel PM Templates

MS Word Pack
25+ Word PM Templates

Ultimate Project Management Template

Ultimate Resource Management Template

Project Portfolio Management Templates
      • In this topic:
  • VBA List Folders Subfolders in Directory: Project Approach
    • List Folders Subfolders :Code and explanation for each control
    • Step 1: Disable Screen Updating is used to stop screen flickering and Disable Events is used to avoid interrupted dialog boxes or popups.
    • Step 2: Declaring variables which are using in the entire project.
    • Step 3: Browse Main Folder or Directory Folder
      • Function to Browse Folder:
    • Step 4: Deleting the ‘Folder Details’ Worksheet if it exists in the Workbook. And Display Alerts is used to stop pop-ups while deleting Worksheet.
    • Step 5: Adding a new WorkSheet at the end of the Worksheet. Naming as ‘Folder Details’. And finally it is assigned it to an object (shtFldDetails).
    • Step 6: Create Main Title and Headers
    • Step 7: Call Sub Procedure from Main Procedure
      • Sub Procedure : sbListAllFolders
    • Step 8: Enabling or TurnOn Screen Update and Events at the end of the project.
    • List Folders Subfolders :Final VBA Module Code(Macro):
      • First Main Procedure
      • Second Sub Procedure used in Main Module
      • Function to Browse Folder
    • Assign List Folders and Sub Folders from Directory macro to a Shape on the Worksheet:
    • List Folders Subfolders Project:Instructions to Execute the Procedure
    • Download List Folders SubFolders from Directory – Excel VBA Project:
    • Related articles about files and folders:

VBA Reference

Effortlessly
Manage Your Projects

120+ Project Management Templates

Seamlessly manage your projects with our powerful & multi-purpose templates for project management.

120+ PM Templates Includes:
By PNRaoLast Updated: March 2, 2023

5 Comments

  1. Holger
    October 8, 2017 at 11:13 PM — Reply

    Thanks for explaining the concepts to deal with Folders and Subfolders using VBA. It is very helpful.

  2. Dr. Soni
    April 21, 2018 at 8:11 PM — Reply

    This is a great help to the beginners like me. Thanks for publishing the code.

  3. BRZ
    July 11, 2018 at 12:26 AM — Reply

    How can I also get a list of files in each folder/subfolder?

  4. Eline
    June 3, 2020 at 6:38 PM — Reply

    Hi, thanks for the code. I want a list of a folder and its subfolders but to a certain level. Example: only subfolders two levels down. How do I add this to this code?

  5. David
    November 29, 2020 at 5:09 AM — Reply

    Excellent information. Thank you so much!

Effectively Manage Your
Projects and  Resources

With Our Professional and Premium Project Management Templates!

ANALYSISTABS.COM provides free and premium project management tools, templates and dashboards for effectively managing the projects and analyzing the data.

We’re a crew of professionals expertise in Excel VBA, Business Analysis, Project Management. We’re Sharing our map to Project success with innovative tools, templates, tutorials and tips.

Project Management
Excel VBA

Download Free Excel 2007, 2010, 2013 Add-in for Creating Innovative Dashboards, Tools for Data Mining, Analysis, Visualization. Learn VBA for MS Excel, Word, PowerPoint, Access, Outlook to develop applications for retail, insurance, banking, finance, telecom, healthcare domains.

Analysistabs Logo

Page load link

VBA Projects With Source Code

3 Realtime VBA Projects
with Source Code!

Take Your Projects To The Next Level By Exploring Our Professional Projects

Go to Top

#excel #vba

Вопрос:

  • Я хочу получить список всех подкаталогов в каталоге.
  • Если это сработает, я хочу расширить его до рекурсивной функции.

Однако мой первоначальный подход к получению поддиров терпит неудачу. Он просто показывает все, включая файлы:

 sDir = Dir(sPath, vbDirectory)
Do Until LenB(sDir) = 0
    Debug.Print sDir
    sDir = Dir
Loop
 

Список начинается с » .. «и нескольких папок и заканчивается файлами». txt».


Редактировать:
Я должен добавить, что это должно выполняться в Word, а не в Excel (многие функции недоступны в Word), и это Office 2010.


ПРАВКА 2:

Можно определить тип результата, используя

 iAtt = GetAttr(sPath amp; sDir)
If CBool(iAtt And vbDirectory) Then
   ...
End If 
 

Но это создало мне новые проблемы, так что теперь я использую код, основанный на Scripting.FileSystemObject .

Комментарии:

1. Я хотел бы придерживаться только vba. Не скриптовый хост или другие трюки с базами dll. И он должен работать с Word of Office 2010. В лучшем случае с Dir , так как я хотел бы знать, почему мой пример терпит неудачу.

Ответ №1:

Обновлено в июле 2014 года: Добавлена PowerShell опция и сокращен второй код только для списка папок

Приведенные ниже методы, которые запускают полный рекурсивный процесс вместо FileSearch устаревшего в Office 2007. (Два последних кода используют Excel только для вывода — этот вывод можно удалить для запуска в Word)

  1. Ракушка PowerShell
  2. Использование FSO с Dir для фильтрации типа файла. Получено из этого ответа EE, который находится за платежной системой EE. Это больше, чем вы просили (список папок), но я думаю, что это полезно, так как это дает вам множество результатов для дальнейшей работы
  3. С помощью Dir . Этот пример взят из моего ответа, который я предоставил на другом сайте

1. Использование PowerShell для сброса всех папок ниже C:temp в файл csv

 Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:tempfilename.csv", 1)
End Sub
 

2. Использование FileScriptingObject для сброса всех папок ниже C:temp в 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 Использование 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=showflatamp;Number=160880amp;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:" amp; "{impersonationLevel=impersonate}!" amp; strComputer amp; "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 " amp; 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 amp; "*.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
 

Комментарии:

1. Хороший пример 🙂 Черт! это не позволяет мне голосовать за это. Похоже, что вы уже проголосовали за это 26 марта 😀

2. Я бы использовал коллекцию вместо повторного отображения массива в цикле. excelmacromastery.com/excel-vba-collections

Ответ №2:

Вам было бы лучше использовать объект FileSystemObject. Я так думаю.

Чтобы назвать это, вам просто нужно, скажем: папки со списками «c:data»

 Sub listfolders(startfolder)
''Reference Windows Script Host Object Model
''If you prefer, just Dim everything as Object
''and use CreateObject("Scripting.FileSystemObject")
Dim fs As New FileSystemObject
Dim fl1 As Folder
Dim fl2 As Folder

Set fl1 = fs.GetFolder(startfolder)

For Each fl2 In fl1.SubFolders
    Debug.Print fl2.Path
    listfolders fl2.Path
Next

End Sub
 

Комментарии:

1. Я думаю, что цель вопроса состояла в том, чтобы найти все подкаталоги, как только будет решена начальная проблема поиска вложенных папок первого уровня, т. Е.»Если это сработает, я хочу расширить его до рекурсивной функции».

2. @brettdj Это было не так, как я это прочитал. Я прочитал это как «если код работает», а не «если каталог найден». В любом случае тот факт, что объект FileSystemObject находит каталоги, поможет, в конце концов, строку рекурсии можно легко закомментировать, после чего будут перечислены все каталоги первого уровня.

3. Невозможно: Dim FS As New FileSystemObject выдает мне «Тип не определен»

4. @MatthiasPospiech Возможно, вы не видели комментарий непосредственно над тусклой строкой, в котором говорится, какая ссылка требуется, и предлагается альтернатива, если вы не хотите добавлять ссылку?

5. @SandPiper, вот почему он сказал " If you prefer, just Dim everything as Object and use CreateObject("Scripting.FileSystemObject") "

Ответ №3:

Вот решение VBA, без использования внешних объектов.

Из-за ограничений Dir() функции вам нужно получить все содержимое каждой папки сразу, а не во время обхода с помощью рекурсивного алгоритма.

 Function GetFilesIn(Folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder amp; "*")
  Do While F <> ""
    GetFilesIn.Add F
    F = Dir
  Loop
End Function

Function GetFoldersIn(Folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(Folder amp; "*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder amp; "" amp; F) And vbDirectory Then GetFoldersIn.Add F
    F = Dir
  Loop
End Function

Sub Test()
  Dim C As Collection, F

  Debug.Print
  Debug.Print "Files in C:"
  Set C = GetFilesIn("C:")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "Folders in C:"
  Set C = GetFoldersIn("C:")
  For Each F In C
    Debug.Print F
  Next F
End Sub
 

Редактировать

Эта версия копается во вложенных папках и возвращает полные имена путей вместо того, чтобы возвращать только имя файла или папки.

Не запускайте тест на всем диске C!!

 Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder amp; "*")
  Do While F <> ""
    GetFilesIn.Add JoinPaths(Folder, F)
    F = Dir
  Loop

  If Recursive Then
    Dim SubFolder, SubFile
    For Each SubFolder In GetFoldersIn(Folder)
      If Right(SubFolder, 2) <> "." And Right(SubFolder, 3) <> ".." Then
        For Each SubFile In GetFilesIn(CStr(SubFolder), True)
          GetFilesIn.Add SubFile
        Next SubFile
      End If
    Next SubFolder
  End If
End Function

Function GetFoldersIn(Folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(Folder amp; "*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder amp; "" amp; F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F)
    F = Dir
  Loop
End Function

Function JoinPaths(Path1 As String, Path2 As String) As String
  JoinPaths = Replace(Path1 amp; "" amp; Path2, "", "")
End Function

Sub Test()
  Dim C As Collection, F

  Debug.Print
  Debug.Print "Files in C:"
  Set C = GetFilesIn("C:")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "Folders in C:"
  Set C = GetFoldersIn("C:")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "All files in C:"
  Set C = GetFilesIn("C:", True)
  For Each F In C
    Debug.Print F
  Next F
End Sub
 

Комментарии:

1. он не копается во вложенных папках

2. @Qbik Я добавил версию, которая копается во вложенных папках.

Ответ №4:

Вот простая версия без использования Scripting.FileSystemObject , потому что я нашел ее медленной и ненадежной. В частности .Name , метод замедлял все. Также я проверил это в Excel, но я не думаю, что что-то, что я использовал, было бы недоступно в Word.

Сначала некоторые функции:

Это объединяет две строки для создания пути к файлу, аналогично os.path.join тому, как в python. Это полезно для того, чтобы не нужно было запоминать, нажали ли вы на это «» в конце своего пути.

 Const sep as String = ""

Function pjoin(root_path As String, file_path As String) As String
    If right(root_path, 1) = sep Then
        pjoin = root_path amp; file_path
    Else
        pjoin = root_path amp; sep amp; file_path
    End If
End Function
 

Это создаст коллекцию вложенных элементов корневого каталога root_path

 Function subItems(root_path As String, Optional pat As String = "*", _
                  Optional vbtype As Integer = vbNormal) As Collection
    Set subItems = New Collection
    Dim sub_item As String
    sub_item= Dir(pjoin(root_path, pat), vbtype)
    While sub_item <> ""
        subItems.Add (pjoin(root_path, sub_item))
        sub_item = Dir()
    Wend
End Function
 

Это создает коллекцию вложенных элементов в каталоге root_path , которая включает папки, а затем удаляет элементы, которые не являются папками, из коллекции. И он может при необходимости удалить эти . файлы и .. папки

 Function subFolders(root_path As String, Optional pat As String = "", _
                    Optional skipDots As Boolean = True) As Collection
    Set subFolders = subItems(root_path, pat, vbDirectory)
    If skipDots Then
        Dim dot As String
        Dim dotdot As String
        dot = pjoin(root_path, ".")
        dotdot = dot amp; "."
        Do While subFolders.Item(1) = dot _
        Or subFolders.Item(1) = dotdot
            subFolders.remove (1)
            If subFolders.Count = 0 Then Exit Do
        Loop
    End If
    For i = subFolders.Count To 1 Step -1
        ' This comparison could be replaced by and `fileExists` function
        If Dir(subFolders.Item(i), vbNormal) <> "" Then
            subFolders.remove (i)
        End If
    Next i
End Function
 

Наконец, функция рекурсивного поиска, основанная на чьей-то другой функции с этого сайта, которая использовалась Scripting.FileSystemObject , я не проводил никаких сравнительных тестов между ней и оригиналом. Если я снова найду этот пост, я свяжу его. Примечание collec передается по ссылке, поэтому создайте новую коллекцию и вызовите этот раздел, чтобы заполнить ее. Пропуск vbType:=vbDirectory для всех вложенных папок.

 Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _
         Optional vbType as Integer = vbNormal)
    Dim subF as Collection
    Dim subD as Collection
    Set subF = subItems(root_path, pat, vbType)
    For Each sub_file In subF
        collec.Add sub_file 
    Next sub_file 
    Set subD = subFolders(root_path)
    For Each sub_folder In subD
        walk sub_folder , collec, pat, vbType
    Next sub_folder 
End Sub
 

Комментарии:

1. Действительно. Имя очень медленно отображается на объекте папки

Данный макрос позволяет получить список папок, расположенных в выбранной папке (каталоге)

Если надо получить список папок, имена которых удовлетворяют определённому критерию, используйте маску поиска (параметр 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

Понравилась статья? Поделить с друзьями:
  • Vba word сохранить все
  • Vba word создать папку
  • Vba word создание таблиц
  • Vba word случайное число
  • Vba word скопировать весь текст