Leere Ordner!

Ab einem wählbaren Startordner soll das gesamte Verzeichnis inklusive aller Unterordner nach leeren Ordnern durchsucht werden - diese werden im "Direktfenster" (VBA-Editor Strg+G) aufgelistet. Zwei Versionen - einmal für Excel ab XP (2002) und einmal für Excel97.

Leere Ordner auflisten... [ZIP, 110 KB]

Code ab Excel XP (2002):

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Dim objSubFolder As Object
Dim objTMPFolder As Object
Dim objFolder As Object
Dim objFSO As Object
Public Sub Emty_Folder_List()
Dim strDirOld As String
Dim strTMP As String
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTMP = fncFolder("C:\")
If strTMP <> "" Then getSubFolders strTMP
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Call SetCurrentDirectory(strDirOld$)
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
Private Function getSubFolders(strTMPPath)
Set objFolder = objFSO.GetFolder(strTMPPath)
Set objSubFolder = objFolder.SubFolders
For Each objTMPFolder In objSubFolder
If objTMPFolder.Files.Count = 0 And _
objTMPFolder.SubFolders.Count = 0 Then
Debug.Print objTMPFolder.Path
End If
getSubFolders objTMPFolder.Path
Next
End Function
Private Function fncFolder(strPath As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = strPath
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Else
fncFolder = "": Exit Function
End If
End With
fncFolder = strPath
End Function



Code Excel 97:

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Dim objSubFolder As Object
Dim objTMPFolder As Object
Dim objFolder As Object
Dim objFSO As Object
Public Sub Emty_Folder_List_97()
Dim strDirOld As String
Dim objShell As Object
Dim varDir As Variant
Dim strTMP As String
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
On Error Resume Next
strTMP = varDir.Self.Path
On Error GoTo 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If strTMP <> "" Then getSubFolders strTMP
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
Call SetCurrentDirectory(strDirOld$)
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set varDir = Nothing
Set objShell = Nothing
End Sub
Private Function getSubFolders(strTMPPath)
Set objFolder = objFSO.GetFolder(strTMPPath)
Set objSubFolder = objFolder.SubFolders
For Each objTMPFolder In objSubFolder
If objTMPFolder.Files.Count = 0 And _
objTMPFolder.SubFolders.Count = 0 Then
Debug.Print objTMPFolder.Path
End If
getSubFolders objTMPFolder.Path
Next
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...