Ordner- und Unterordnernamen auslesen

[Tobias Harnegg]

Muss vorrausschicken, das ich VBA-Anfänger bin, daher die doofen
Fragen:

Ich hab hier ein Script, das mir Ordnernamen ausliest:
Das funktioniert auch gut, aber ich wollte ein paar Änderungen
vornehmen, die mir nicht gelungen sind:

1.) Ich möchte, das der Pfad direkt im Script ausgewählt wird
(also keine Auswahlmöglichkeit) Pfad soll der sein, in dem das
Dokument liegt.
setobjFolder=Thisworkbook.Path klappt leider nicht.

2.) Wenn ich c:\docs als ordner angegeben habe,bekomme ich die
Unterordner-Namen folgendermassen geliefert:

A1: c:\docs\01\Ordner X
A2: c:\docs\01\Ordner Y
A3 c:\docs\02\Ordner Z

Stattdessen häte ich lieber nur die ordner selbst, ohne kompletten
pfad:

A1: 01\Ordner X
A2: 01\Ordner Y
A3: 02\Ordner Z

Am allerliebsten - vermutlich aber auch am kompliziertesten, wäre es
mir so

A1: Ordner X, OrdnerY
A2 Ordner Z


3.) Statt bei A1, hätte ich das ganze lieber in Spalte B, beginnend
bei B9


Hintergrund:
Ich bastle an einem Mini-Redaktionssystem für ein kleines Magazin.
Änderungen können mit Datumsstempel für jede Seite eingegeben werden,
so sieht der Layouter immer was aktuell ist. Die Exel-Datei liegt im
Hauptverzeichnis einer Ordnerstruktur, in der für jede Seite ein
Ordner angelegt wurde (also Ordner \01,\02,\03,...) In jedem Dieser
Ordner befindet sich ein (oder mehrere) weitere Ordner mit dem Namen
des Artikels. Und genau Diese Namen möchte ich gerne aufgelistet
haben. Wenn jemand die xlsm Datei haben möchte, ich schicke sie gerne
zu!

Hier nun aber das Skript, von dem ich sprach:

(Die Frage ist nun natürlich, wie ich es abändern muss, damit meine 3
"Wünsche" erfüllt werden)



***********************************************************************************
Option Explicit

Dim z
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0,
ThisWorkbook.Path)
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
Else: Exit Sub
End If
z = 1
Schreiben objItem.Path, True 'true wenn die Unterordner auch wieder
geschrieben werden sollen
'Sonst false oder weglassen
End Sub

Public Sub Schreiben(V, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.getfolder(V)
Select Case sbfolds
Case True
For Each Unterordner In datei.subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Schreiben Unterordner, True
Next
Case False
For Each Unterordner In datei.subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub

************************************************************************************


Vielen Dank für Hilfe,
Tobias

[Andreas Killer]

Post by Tobias Harnegg
Muss vorrausschicken, das ich VBA-Anfänger bin, daher die doofen

Es gibt keine dummen Fragen, nur dumme Antworten.

Post by Tobias Harnegg
Das funktioniert auch gut, aber ich wollte ein paar Änderungen
1.) Ich möchte, das der Pfad direkt im Script ausgewählt wird
(also keine Auswahlmöglichkeit) Pfad soll der sein, in dem das
Dokument liegt.
setobjFolder=Thisworkbook.Path klappt leider nicht.

ThisWorkBook gibt's ja auch nicht, aber

S = ActiveWorkbook.Path

geht schon. Nur muss das WorkBook gespeichert sein, sonst bekommst Du ""
zurück.

Post by Tobias Harnegg
2.) Wenn ich c:\docs als ordner angegeben habe,bekomme ich die

...

Post by Tobias Harnegg
Stattdessen häte ich lieber nur die ordner selbst, ohne kompletten

...

Post by Tobias Harnegg
Am allerliebsten - vermutlich aber auch am kompliziertesten, wäre es
mir so

Du mixt 2 Anforderungen, teile sie in 2 Schritte.

1. Lese alle Ordner ein
2. Gibt die Ordnernamen nach Deinen Anforderungen aus.

Andreas.

Sub Test()
Dim Pfade() As String
Dim Anzahl As Long
Anzahl = GetSubFoldersA(ActiveWorkbook.Path, Pfade)
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
If fs Is Nothing Then Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Pfad)
Set GetSubFolders = f.SubFolders
Set f = Nothing
End Function

Function GetSubFoldersA(ByVal Pfad As String, ByRef PfadArray() As
String, Optional SearchSubFolders As Boolean = True) 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, Sf As Object, f As Object

'Verzeichnisse festellen
GetSubFoldersA = 0
On Error Resume Next
Set Sf = GetSubFolders(Pfad)
If Err.Number <> 0 Then GoTo ExitPoint
If Sf.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 Sf.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 < Sf.Count Then
ReDim Preserve PfadArray(LBound(PfadArray) To I + Sf.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 Sf
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)
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 Sf = Nothing
End Function

[Tobias Harnegg]

Vielen Dank,

Nachdem mir vieles wie erwartet zu komplex war um es wirklich
nachzuvollziehen, hab ichs erst mal ausprobiert,
und bekomme die Fehlermeldung:

"Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer
Eigenschaft"

??

lg tob

PS: Dieser Fehler taucht schon auf bei GetSubfoldersA

Post by Andreas Killer

Post by Tobias Harnegg
Muss vorrausschicken, das ich VBA-Anfänger bin, daher die doofen

Es gibt keine dummen Fragen, nur dumme Antworten.

Post by Tobias Harnegg
Das funktioniert auch gut, aber ich wollte ein paar Änderungen
1.) Ich möchte, das der Pfad direkt im Script ausgewählt wird
    (also keine Auswahlmöglichkeit)  Pfad soll der sein, in dem das
Dokument liegt.
    setobjFolder=Thisworkbook.Path   klappt leider nicht.

ThisWorkBook gibt's ja auch nicht, aber
S = ActiveWorkbook.Path
geht schon. Nur muss das WorkBook gespeichert sein, sonst bekommst Du ""
zurück.

Post by Tobias Harnegg
2.) Wenn ich c:\docs als ordner angegeben habe,bekomme  ich die

...

Post by Tobias Harnegg
Stattdessen häte ich lieber nur die ordner selbst, ohne kompletten

...

Post by Tobias Harnegg
Am allerliebsten - vermutlich aber auch am kompliziertesten, wäre es
mir so

Du mixt 2 Anforderungen, teile sie in 2 Schritte.
1. Lese alle Ordner ein
2. Gibt die Ordnernamen nach Deinen Anforderungen aus.
Andreas.
Sub Test()
   Dim Pfade() As String
   Dim Anzahl As Long
   Anzahl = GetSubFoldersA(ActiveWorkbook.Path, Pfade)
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
   If fs Is Nothing Then Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.GetFolder(Pfad)
   Set GetSubFolders = f.SubFolders
   Set f = Nothing
End Function
Function GetSubFoldersA(ByVal Pfad As String, ByRef PfadArray() As
String, Optional SearchSubFolders As Boolean = True) 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, Sf As Object, f As Object
   'Verzeichnisse festellen
   GetSubFoldersA = 0
   On Error Resume Next
   Set Sf = GetSubFolders(Pfad)
   If Err.Number <> 0 Then GoTo ExitPoint
   If Sf.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 Sf.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 < Sf.Count Then
       ReDim Preserve PfadArray(LBound(PfadArray) To I + Sf.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 Sf
     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)
       Select Case Err.Number
         Case 0
         Case 70
           'Zugriff verweigert
           Err.Clear
         Case Else
           Exit Do
       End Select
     Loop
   End If
   GetSubFoldersA = U
   'Subfolder-Objekt freigeben
   Set Sf = Nothing
End Function

[Andreas Killer]

Post by Tobias Harnegg
Nachdem mir vieles wie erwartet zu komplex war um es wirklich
nachzuvollziehen, hab ichs erst mal ausprobiert,
"Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer
Eigenschaft"

Hmm, liegt vielleicht am Mail-Format, viele Programme brechen die Zeilen
ab einer gewissen Läge um, was bei VBA-Code natürlich fatale Folgen hat.

Ich hängs nochmal umgebrochen dran. Kuckmal ob da nicht eine oder
mehrere Zeilen rot sind wenn Du Dir das in den Editor kopiert hast, idR
gehört die dann an die obige dran.

BTW, wenn Du alle Unterverzeichnisbäume durchlesen läßt ist es ratsam
das Array nachher alphabetisch zu sortieren, das macht es einfacher,
dann hast Du sowas wie

c:\a
c:\b
c:\b\c1
c:\b\c1\d
c:\b\c2
c:\c

und nicht

c:\a
c:\b
c:\c
c:\b\c1
c:\b\c2
c:\b\c1\d

im array drin. Dann musst Du nur schauen ob der vorhergehende Pfad am
Anfang des aktuellen steht um zu erkennen das dieser ein
Unterverzeichnis der vorherigen ist.

Und wenn Du von dem jetzigen nur den Teil ab Len(VorherigerPfad)+1
nimmst, dann hast Du nur den Unterverzeichnisbaum den Du möchtest.

Wie Du das in der Tabelle darstellst überlasse ich Dir, das bekommst Du
ohne mich hin und ein Quicksort für ein Array in VBA findet man leicht
im Netz mit Google. Falls nicht musst Du Dich nochmal melden.

Andreas.


Sub Test()
Dim Pfade() As String
Dim Anzahl As Long
Anzahl = GetSubFoldersA(ActiveWorkbook.Path, Pfade)
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
If fs Is Nothing Then _
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Pfad)
Set GetSubFolders = f.SubFolders
Set f = Nothing
End Function

Function GetSubFoldersA(ByVal Pfad As String, _
ByRef PfadArray() As String, _
Optional SearchSubFolders As Boolean = True) 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, Sf As Object, f As Object

'Verzeichnisse festellen
GetSubFoldersA = 0
On Error Resume Next
Set Sf = GetSubFolders(Pfad)
If Err.Number <> 0 Then GoTo ExitPoint
If Sf.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 Sf.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 < Sf.Count Then
ReDim Preserve _
PfadArray(LBound(PfadArray) To I + Sf.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 Sf
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)
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 Sf = Nothing
End Function

[Tobias Harnegg]

Vielen Dank für die Mühe!!!

Jetzt hab ich bei deinem makro zwar keine Fehlermeldung mehr, aber
auch keinen Output...hm...

Ich habe jetzt schon 3 verschiedene Beispiele gefunden, aber keines
ist ideal,

Hab alles sortiert, in die datei auslesen_test.xls gegeben und
hochgeladen
http://sites.google.com/site/excelauswahl/
(Dein Beispiel ist auf tabellenblatt mit dem namen "Beispiel A.K
II" )

Ich weiß nicht ob Du noch zeit & lust hast Dir das anzusehen,
würd auch verstehen wenn nicht, in jedem fall schon mal vielen dank!

PS: Die datei mit dem redaktionssystem ist auch im zip - die würde
ich, wenn
alles fertig ist, natürlich der community zu verfügung stellen -
erleichtert mir schon
im derzeitgen zustand die arbeit sehr. gibts eine seite, wo man so was
hochladen kann?

[Andreas Killer]

Post by Tobias Harnegg
Jetzt hab ich bei deinem makro zwar keine Fehlermeldung mehr, aber
auch keinen Output...hm...

Völlig korrekt. GetSubFoldersA liefert Dir nur die Pfade in einem Array.

Diese in eine Tabelle zu schreiben überlasse ich Dir. So als Anstoß:

Sub Test()
Dim Pfade() As String
Dim Anzahl As Long
Anzahl = GetSubFoldersA(ActiveWorkbook.Path, Pfade)

for I = 0 to Anzahl-1
Cells(I+1, 1) = Pfade(I)
next
End Sub

Andreas.

[Tobias Harnegg]

Dank dir.

nachdem mich das ganze aber immer weiter weg von meinem ursprünglichen
ziel geführt hab,
hab ich es jetzt folgendermassen - ganz anders - gelöst:

-------------------------

sub(folder_auslesen)
Dim fso, f, sf, fldr, folderlist
Dim I
Set fso = CreateObject("Scripting.FileSystemObject")
For I = 9 To 1000 'Assuming less than 1000 lines!
If (Cells(I, 1) <> "") Then
Cells(I, 2) = "" 'löscht
bestehende daten
If (fso.folderexists(Cells(I, 1))) Then 'kein fehler wenn
ordner nicht existiert
folderlist = "" 'löscht liste von
vorherigen folder
Set f = fso.GetFolder(Cells(I, 1)) 'folder name
Set sf = f.SubFolders 'subfolder liste
For Each fldr In sf
If (folderlist = "") Then 'erster folder
braucht kein komma (,)
folderlist = fldr.Name '
Else
folderlist = folderlist & ", " & fldr.Name
End If
Next fldr
Cells(I, 2) = folderlist 'fügt liste hinzu
End If
End If
Next I

end sub

----------------------

funktioniert gut auf die art :)

Post by Andreas Killer

Post by Tobias Harnegg
Jetzt hab ich bei deinem makro zwar keine Fehlermeldung mehr, aber
auch keinen Output...hm...

Völlig korrekt. GetSubFoldersA liefert Dir nur die Pfade in einem Array.
Sub Test()
   Dim Pfade() As String
   Dim Anzahl As Long
   Anzahl = GetSubFoldersA(ActiveWorkbook.Path, Pfade)
   for I = 0 to Anzahl-1
      Cells(I+1, 1) = Pfade(I)
   next
End Sub
Andreas.