Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zur Löschung von leeren Verzeichnissen in einem Verzeichnisbaum to delete empty folders in a foldertree

Dieses Programm kann als Zusatz für Langmeier Backup verwendet werden und kann gestartet werden von einem Sicherungsauftrag von Langmeier Backup

This program can be used as an addition to Langmeier Backup and can get started by a data saving task of Langmeier Backup

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
3. Aug. 2012 Aug 3rd 2012

' Delete empty folders

Option Explicit

' Constants, Objects + Variables

Const Yes = 0, No = 1 ' Constants
Dim fso, f ' Objects
Dim BaseFolder, Path ' Strings
Dim NrOfFolders, LowestFolder, item ' Numerics
Dim FolderEmpty ' Booleans
Dim Folderlist ' Arrays

' Instantiation

Set fso = CreateObject("Scripting.FileSystemObject")

' User-Parameter-Settlings

BaseFolder = "c:\Dokumente und Einstellungen\User\Dokumente\BaseFolder"
DeleteBaseFolder = Yes ' DeleteBaseFolder too (Yes or No)

' Program

If fso.FolderExists(BaseFolder) Then
    NrOfFolders = CreateSubFolderList (BaseFolder)
    LowestFolder = DeleteBaseFolder
    For item = NrOfFolders To LowestFolder Step -1
        FolderEmpty = CheckIfFolderEmpty(Folderlist(item))
        If FolderEmpty Then
            Path = Folderlist(item)
            If Right(Path,1) = "\" Then Path = Left(Path, Len(Path)-1) ' Must be without Backslash
            fso.DeleteFolder(Path)
        End If
    Next
    MsgBox "Procedure done"
Else
    MsgBox "Specified Basefolder does not exist"
End If

' End of Program

' Procedures

Function CreateSubFolderList (AnyFolder)
    Dim Pointer, FolderGroup, ChosenFolder
    ReDim Folderlist(0) : Folderlist(0) = AnyFolder & "\": Pointer = -1
    Do
        Pointer = Pointer + 1
        On Error Resume Next
        Set f = fso.GetFolder(Folderlist(Pointer))
        Set FolderGroup = f.SubFolders
        For Each ChosenFolder In FolderGroup
            ReDim Preserve Folderlist( UBound (Folderlist) + 1 )
            Folderlist(UBound (Folderlist)) = ChosenFolder & "\"
        Next
    Loop Until Pointer >= UBound (Folderlist)
    f.Close(): SortFolderlist: CreateSubFolderList = UBound (Folderlist)
End Function

Sub SortFolderlist
    Dim FirstUnsorted, TopPos, TopWord, ProbePos
    For FirstUnsorted = 1 To UBound (Folderlist)
        TopPos=FirstUnsorted: TopWord = Folderlist(FirstUnsorted-1)
        For ProbePos = FirstUnsorted To UBound (Folderlist)+1
            If Folderlist(ProbePos-1) < TopWord Then TopPos = ProbePos: TopWord = Folderlist(TopPos-1)
        Next
        If TopPos <> FirstUnsorted Then
            Folderlist(TopPos-1) = Folderlist(FirstUnsorted-1)
            Folderlist(FirstUnsorted-1) = TopWord
        End If
    Next
End Sub

Function CheckIfFolderEmpty(folderspec)
    Dim ffo, ffi, f1, FolderEmpty
    Set f = fso.GetFolder(folderspec)
    Set ffo = f.SubFolders
    Set ffi = f.Files
    FolderEmpty = True
    For Each f1 In ffo
        FolderEmpty = False
    Next
    For Each f1 In ffi
        FolderEmpty = False
    Next
    CheckIfFolderEmpty = FolderEmpty
End Function

' End of Procedures