Ordnernamen auslesen

09/02/2010 - 11:38 von Hans Otany | Report spam
Hallo,

ich habe im Dateisystem einen Ordner mit vier Unterordnern. Darunter
sind jeweils wieder eine unbestimmte Zahl an Unterordnern welche mit
unzàhligen Daten gefüllt sind.
Ich würde jetzt gern auf Knopfdruck eine Exceldatei erstellen lassen, in
der nur die Namen der Ordner der ersten drei Ebenen aufgeführt sind und
zu welchem übergeordneten Ordner sie gehören. Nicht aber den gesamten
Inhalt darunter.

Ist so etwas möglich (bspw. mit einem Makro)?

Vielen Dank.

Beste Grüße.

Hans
 

Lesen sie die antworten

#1 Andreas Killer
09/02/2010 - 12:27 | Warnen spam
On 9 Feb., 11:38, Hans Otany wrote:

ich habe im Dateisystem einen Ordner mit vier Unterordnern. Darunter
sind jeweils wieder eine unbestimmte Zahl an Unterordnern welche mit
unzàhligen Daten gefüllt sind.
Ich würde jetzt gern auf Knopfdruck eine Exceldatei erstellen lassen, in
der nur die Namen der Ordner der ersten drei Ebenen aufgeführt sind und
zu welchem übergeordneten Ordner sie gehören. Nicht aber den gesamten
Inhalt darunter.


Kein Problem.

Andreas.

Option Explicit

Sub Test()
Const Ebenen = 3
Dim Pfade() As String
Dim Anzahl As Long, Y As Long
'3 Ebenen einlesen
Anzahl = GetSubFoldersA("C:\Programme", Pfade, True, Ebenen)
'In Spalte A schreiben und...
For Y = 1 To Anzahl
Cells(Y, 1) = Pfade(Y - 1)
Next
'...sortieren
Cells(1, 1).Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlNo
End Sub

Function GetSubFolders(ByVal Pfad As String) As Variant
'Gibt eine Folders-Auflistung zurück, die aus allen in einem _
bestimmten Ordner enthaltenen Ordnern, einschließlich _
derer mit dem Attribut "Verborgen" und "Systemdatei", _
besteht.
Dim F As Object, fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFolder(Pfad)
Set GetSubFolders = F.SubFolders
Set F = Nothing
Set fs = Nothing
End Function

Function GetSubFoldersA( _
ByVal Pfad As String, _
ByRef PfadArray() As String, _
Optional SearchSubFolders As Boolean = True, _
Optional Level As Long = 2147483647) As Long
'Liefert die Anzahl der Unterverzeichnisse in Pfad und deren _
Pfadnamen in PfadArray, 0 für keine.
Dim I As Long, J As Long, U As Long, SubF As Object, F As _
Object

'Verzeichnisse festellen
GetSubFoldersA = 0
If Level < 0 Then Exit Function
On Error Resume Next
Set SubF = GetSubFolders(Pfad)
If Err.Number <> 0 Then GoTo ExitPoint
If SubF.Count = 0 Then GoTo ExitPoint

'Obere Grenze des Array feststellen
J = UBound(PfadArray)
If Err.Number <> 0 Then
'Es ist () => leer
I = -1
ReDim PfadArray(0 To SubF.Count - 1) As String
Else
I = J
'Letztes Element feststellen
Do While Len(PfadArray(I)) = 0
I = I - 1
If I < LBound(PfadArray) Then Exit Do
Loop
'Genug Platz um die Namen aufzunehmen?
If J - I < SubF.Count Then
ReDim Preserve PfadArray(LBound(PfadArray) To I + SubF _
.Count) As String
'Konnte das Datenfeld dimensioniert werden?
If Err.Number <> 0 Then GoTo ExitPoint
End If
End If
On Error GoTo 0

'Start im Array für Unterverzeichnissuche merken
J = I
'Alle Verzeichnisse ins Array eintragen
For Each F In SubF
I = I + 1
PfadArray(I) = F
Next
'Anzahl hinzugefügter Eintràge im Array berechnen
U = I - J

'Durchlaufe alle gefundenen Unterverzeichnisse
If SearchSubFolders Then
Do While J < I
J = J + 1
'Addiere Anzahl gefundener Unterverzeichnisse
U = U + GetSubFoldersA(PfadArray(J), PfadArray, _
SearchSubFolders, Level - 1)
Select Case Err.Number
Case 0
Case 70
'Zugriff verweigert
Err.Clear
Case Else
Exit Do
End Select
Loop
End If
GetSubFoldersA = U

ExitPoint:
'Subfolder-Objekt freigeben
Set SubF = Nothing
End Function

Ähnliche fragen