Ordner- und Unterordnernamen auslesen

07/02/2009 - 01:48 von Tobias Harnegg | Report spam
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
 

Lesen sie die antworten

#1 Andreas Killer
07/02/2009 - 09:40 | Warnen spam
Tobias Harnegg schrieb:

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


Es gibt keine dummen Fragen, nur dumme Antworten.

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.


ThisWorkBook gibt's ja auch nicht, aber

S = ActiveWorkbook.Path

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

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


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


...
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

Ähnliche fragen