Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление пустых подкаталогов в родительском каталоге., Очистка каталога от подкаталогов без файлов
 
#1
19.01.2024 11:00:02
Добрый день!
Код ниже удаляет пустые каталоги в указанном родительском.
Как доработать макрос, чтобы удаление производилось на всю
глубину вложенности подкаталогов. В приложенной структуре
каталогов должны удалиться каталоги 2 и 5.
Код удаляет только пустой подкаталог 2 с первого уровня
вложенности. Пустым считать каталог без файлов.

Код
Sub DeleteEmptySubfolders()
    Dim FSO, Folder, Subfolder As Object
    Dim FolderPath, UserName As String
    UserName = Environ("USERNAME")
    FolderPath = "C:\Users\UserName\Desktop\ÒÅÑÒ_\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(FolderPath)

    For Each Subfolder In Folder.SubFolders
        If FSO.GetFolder(Subfolder.path).Files.Count = 0 Then
            Subfolder.Delete
        End If
    Next

    Set FSO = Nothing
    Set Folder = Nothing
    Set Subfolder = Nothing
End Sub

Изменено: aesp - 19.01.2024 11:50:41
 
 
 
#2
19.01.2024 11:42:09
Доброе время суток
Вариант
Код
Public Sub removeEmptyFolders()
    Const startPath = "C:\Temp\ТЕСТ_ "
    Dim fso As Object, startFolder As Object, startIsEmpty As Boolean
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set startFolder = fso.GetFolder(startPath)
    startIsEmpty = recursiveDeleteFolder(startFolder)
End Sub

Private Function recursiveDeleteFolder(folder) As Boolean
    Dim folderCollection As Object, nextFolder As Object
    Dim emptyFolderCollection As New Collection
    Dim thisIsEmpty As Boolean, nextIsEmpty As Boolean
    
    Set folderCollection = folder.SubFolders
    thisIsEmpty = (folder.Files.Count = 0)
    If (folderCollection.Count > 0) Then
        For Each nextFolder In folderCollection
            nextIsEmpty = recursiveDeleteFolder(nextFolder)
            thisIsEmpty = thisIsEmpty And nextIsEmpty
            If nextIsEmpty Then emptyFolderCollection.Add nextFolder
        Next
        If Not thisIsEmpty Then
            For Each nextFolder In emptyFolderCollection
                nextFolder.Delete
            Next
        End If
    End If
    recursiveDeleteFolder = thisIsEmpty
End Function
Изменено: Андрей VG - 19.01.2024 13:55:40 (Перемудрил. Несколько лет на VBA не кодировал)
 
 
 
#3
19.01.2024 11:54:22
aesp, добрый день!

Я бы оформил как функцию и вызывал рекурсивно по всем веткам папок (результат True, если ветка пустая и тогда её можно удалить).
Код
UserName = Environ("USERNAME")
FolderPath = "C:\Users\UserName\Desktop\ТЕСТ_\"
DeleteEmptySubfolders (FolderPath)

Function DeleteEmptySubfolders(ByVal FolderPath)
    Dim FSO, Folder, Subfolder
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(FolderPath)

    DeleteEmptySubfolders = True
        
    For Each Subfolder In Folder.SubFolders
        If DeleteEmptySubfolders(Subfolder) Then
            If (FSO.GetFolder(Subfolder.Path).Files.Count = 0) Then
                Subfolder.Delete
            Else
                DeleteEmptySubfolders = False
            End If
        Else
            DeleteEmptySubfolders = False
        End If
    Next
    
    Set FSO = Nothing: Set Folder = Nothing: Set Subfolder = Nothing
End Function
 
 
 
#4
19.01.2024 11:55:12
Андрей VG, Благодарю, работает! Буду вникать :)  
 
 
 
Страницы: 1
Наверх