Verzeichnisstruktur mit VBA auflisten
31.01.2009
Nachtrag bzw. Aktualisierung vom 05.11.2010: Eine neue Variante des Tools inklusive Beschreibung der Funktionen und dem Code ist in meinem weiteren Blog Excel-Ticker zu finden. Verzeichnisse und Dateien mit Windows API Funktionen in Excel auflisten.
In Foren taucht ab und zu die Frage auf, wie alle Unterverzeichnisse Ordners von der Festplatte - z.B. von C:\Programme - in Excel VBA ausgelesen und in einer Tabelle aufgelistetet werden können. Es gibt hierfür zwei Lösungen. Eine, die sich auf das Windows Scripting Modell stützt und eine weitere, die das Windows API nutzt. Wir werden letztere Variante nutzen.
Wenn Sie möchten, können Sie gerne unsere Beispieldatei mit dem Code herunterladen und für Ihre Zwecke anpassen.
Nun, was macht der Code? Zunächst werden Standard-Konstanten für die Windows API - Application Programming Interface - definiert. Übrigens, eine Liste der API Funktionen finden Sie bei MSDN, allerdings in Englisch. Anschließend werden die API Funktionen "importiert", so dass wir diese auch aufrufen können. Die Funktion mlfpGetDirectories() ermittelt in einer Schleife alle Objekte (Dateien, Verzeichnisse, ...) in dem Startordner. Zudem prüft die Funktion, ob dieses Objekt ein Ordner ist und ruft sich selbst rekursiv auf. Jeder Ordner wird in die Ausgabetabelle geschrieben, wobei ein Zähler die aktuelle Tiefe mitführt.
'
' Copyright : 2009 by Maninweb.de - www.excelsharp.de
'
' Version : 0100
'
' Disclaimer : Sie können diesen Code in Ihren Projekten
' frei verwenden.
' Wir würden uns freuen, wenn Sie diesen
' Hinweis auf den Autor beibehalten würden.
'
' .......................................................
' Optionen...
Option Explicit
' Konstanten...
Const MAX_PATH As Long = 259
Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Const FILE_ATTRIBUTE_READONLY As Long = &H1
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100
' Flags...
Private Const cAny As Long = 0
Private Const cDirectories As Long = 1
Private Const cFiles As Long = 2
' Typen...
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
' API Importe...
Private Declare _
Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare _
Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare _
Function FindClose Lib "kernel32" ( _
ByVal hFindFile As Long) As Long
' Verzeichnislister...
Private Function mlfpGetDirectories(Book As String, _
Sheet As String, _
Column As Long, _
Line As Long, _
Root As String, _
Start As Boolean) As Long
Dim b As Boolean
Dim c As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim t As WIN32_FIND_DATA
Dim f As String
Dim r As String
' Initialisieren...
c = 0
i = Line
j = Column
r = Root
h = FindFirstFile(r & "\" & "*.*", t)
' Start...
If Start Then
' Ablegen...
Application.Workbooks(Book).Worksheets(Sheet). _
Cells(i, j).Value = r
' Zähler...
i = i + 1
j = j + 1
End If
' Prüfen...
If h = 0 Then
Exit Function
End If
Do
' Finden...
f = Left(t.cFileName, InStr(t.cFileName, Chr(0)) - 1)
b = CBool((t.dwFileAttributes And _
FILE_ATTRIBUTE_DIRECTORY) <> _
FILE_ATTRIBUTE_DIRECTORY)
' Prüfen...
If Not b Then
' Prüfen...
If CBool(f <> ".") And CBool(f <> "..") Then
' Ablegen...
Application.Workbooks(Book).Worksheets(Sheet). _
Cells(i, j).Value = "'" & f
' Rekursion...
i = mlfpGetDirectories(Book, Sheet, j + 1, i + 1, _
r & "\" & f, False)
End If
End If
Loop While FindNextFile(h, t)
' Schließen...
FindClose h
' Return...
mlfpGetDirectories = i
End Function
' Testfunktion...
Public Sub mlfpGetDirectoriesTester()
' Simple Abfrage...
If Len(ThisWorkbook.Worksheets(1). _
Cells(14, 2).Value) > 0 Then
' Löschen...
ThisWorkbook.Worksheets("Verzeichnisse"). _
Range("$A$1:$IV$32000").ClearContents
' Aufrufen...
mlfpGetDirectories ThisWorkbook.Name, "Verzeichnisse", _
1, 1, ThisWorkbook.Worksheets("Start"). _
Cells(14, 2).Value, True
' Ansicht...
ThisWorkbook.Worksheets("Verzeichnisse").Activate
End If
End Sub
Blog
Neuigkeiten
