Office: Dir(Path, vbDirectory) liefert Dateinamen

Helfe beim Thema Dir(Path, vbDirectory) liefert Dateinamen in Microsoft Access Hilfe um das Problem gemeinsam zu lösen; Hallo, ich schon wieder! Ich versuche mir die Verzeichnisstruktur eines Laufwerks auszulesen und möchte nur die Verzeichnisse ausgegeben bekommen.... Dieses Thema im Forum "Microsoft Access Hilfe" wurde erstellt von Toast78, 14. Februar 2012.

Seite 1 von 2

TOAST78

Toast78

Dir(Path, vbDirectory) liefert Dateinamen

Hallo, ich schon wieder!

Ich versuche mir die Verzeichnisstruktur eines Laufwerks auszulesen und möchte nur die Verzeichnisse ausgegeben bekommen. Aber schon beim ersten Aufruf von Dir(Path, vbDirectory) wird mir eine Datei zurückgegeben. Habe ich die Dir-Funktion falsch verstanden?
Hier mal meine bisherigen geistigen Ergüsse. Aufruf der Prozedur übers Testfenster:
Call readStructure("G:\")
und der Code
Code:

Public Sub readStructure(Path As String, Optional ParentID As Long)
Dim CurrentPath As String
Dim NewParentID As Long
ChDir (Path)
CurrentPath = Dir(Path, vbDirectory)
Do
If CurrentPath "." And CurrentPath ".." Then
If Not IsMissing(ParentID) Then
CodeDb.Execute "INSERT INTO PathStructure (ParentID,Path) VALUES (" & ParentID & _
", '" & Replace(CurrentPath, "'", "''") & "')", DB_FAILONERROR
Else
CodeDb.Execute "INSERT INTO PathStructure (Path) VALUES ('" & _
Replace(CurrentPath, "'", "''") & "')", DB_FAILONERROR
End If
NewParentID = DMax("ParentID", "PathStructure")
Call readStructure(Path & IIf(Right(Path, 1) = "\", "", "\") & CurrentPath, NewParentID)
End If
CurrentPath = Nz(VBA.Dir(, vbDirectory), "")
Loop Until CurrentPath = ""

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

Toast78, 14. Februar 2012

#1
IOS707

ios707

In der Hilfe sieht der Beispielcode von MS aber etwas anders aus:
Code:

' Namen in C:\ anzeigen, die Verzeichnisse darstellen.
Pfad1 = "c:\" ' Pfad setzen.
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Do While Name1 "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 "." And Name1 ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Debug.Print Name1 ' Eintrag nur anzeigen, wenn es sich
End If ' um ein Verzeichnis handelt.
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

ios707, 15. Februar 2012

#2
TOAST78

Toast78

Funktioniert auch nicht. Habe ich schon davor probiert.

Toast78, 15. Februar 2012

#3
GRZI

grzi

Dir(Path, vbDirectory) liefert Dateinamen

Habe hier zwar nichts zum Dir Befehl, arbeite aber des öfteren mit dem FSO!

Musst deinen Code nur etwas anpassen, damit die Debug.Print Ergebnisse wie von dir gewünscht in deiner Tabelle landen!
Code:

'---------------------------------------------------------------------------------------
' Procedure : ListSubFolder
' Author : GRZI
' Date : 16.02.2011
' Purpose : Grundfunktion zur Auflistung von SubFoldern
' Example : ListSubFolder "c:\Users", True
'---------------------------------------------------------------------------------------
'
Function ListSubFolder(sFolder As String, Optional blnAllSubFolders As Boolean = False)
Dim objFSO As Object
Dim Folder As Object
Dim SubFolder As Variant
On Error GoTo gtoErrHdl
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = objFSO.GetFolder(sFolder)

For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Path
If blnAllSubFolders Then ListSubFolder SubFolder.Path, blnAllSubFolders
Next

Set objFSO = Nothing
Set Folder = Nothing
Exit Function

gtoErrHdl:
Select Case Err.Number

Case 70 'Keine Zugriff-Erlaubnis!
Resume Next
Case 424 'Objekt erforderlich - z.B. kein Subfolder
Resume Next
Case 92 'For-Schleife nicht initialisiert - kann nach 424 auftreten!
Resume Next
Case Else
Debug.Print Err.Number & " - " & Err.Description
Resume Next
End Select

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

grzi, 16. Februar 2012

#4
EARLFRED

EarlFred

Hallo Toast,

DIR in Verbindung mit Rekursion hat seine Tücken. Zudem liefert die Option vbDirectory Dateien UND Ordner - aber eben nicht nur.
vgl. hier

Der Ansatz mit FSO wäre auch meine Idee, sofern es nicht zuviele Verzeichnisse sind, denn wirklich schnell ist diese Methode nicht.

Für eine Anfrage auf Excel-Seite hatte ich mal dieses "Skelett" errichtet:
Code:

Option Explicit
Sub Ordnerlister()
Dim fso As Object
Dim f As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("C:\Programme\")

nextSF f

Set f = Nothing
Set fso = Nothing
End Sub
Function nextSF(ByRef f As Object)
Dim sf As Object

With ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
.Offset(0, 0) = f.Path
.Offset(0, 1) = f.Name
End With

For Each sf In f.SubFolders
nextSF sf
Next sf
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Vielleicht hilft's.

@grzi
Du erstellst bei jedem Durchlauf der Rekursion ein neues FSO - da bremst m. E. nur unnötig aus.

Grüße
EarlFred

EarlFred, 16. Februar 2012

#5
ANNE BERG

Anne Berg

Hallo Toast78.

von Toast78

Habe ich die Dir-Funktion falsch verstanden?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ja, oder vermutlich nicht ganz bis zu Ende gedacht... *wink.gif*
Code:

Konstante Wert Beschreibung
vbNormal 0 Normal.
vbHidden 2 Versteckt.
vbSystem 4 Systemdatei.
vbVolume 8 Datenträgerbezeichnung. Falls angegeben, werden alle anderen Attribute ignoriert.
vbDirectory 16 Verzeichnis oder Ordner.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Der Aufbau der Parameterwerte legt den Schluss nahe, dass diese additiv zu verwenden sind, d.h. "0 = normal" (="gib mir die Dateinamen") ist stets dabei, Verzeichnisse und sonstige Attribute nur auf Anforderung. Nur bei Wert 8 ist die Ausnahme von dieser Regel erwähnt. Da bist du wahrscheinlich mit dem o.g. Beispiel besser bedient.

Zuletzt von einem Moderator bearbeitet: 7. Januar 2021

Anne Berg, 16. Februar 2012

#6
GRZI

grzi

von EarlFred

...
@grzi
Du erstellst bei jedem Durchlauf der Rekursion ein neues FSO - da bremst m. E. nur unnötig aus.

Grüße
EarlFred
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ist zwar nur ein Beispiel-Code - aber wo du recht hast!
Performancegewinn ~25%!

Zuletzt von einem Moderator bearbeitet: 7. Januar 2021

grzi, 16. Februar 2012

#7
TOAST78

Toast78

Dir(Path, vbDirectory) liefert Dateinamen

Habe einiges rausgefunden:
Über GetAttr() kann man zwar die Verzeichnisse bekommen, aber die Rekursion klappt tatsächlich nicht, wie EarlFred schon angemerkt hat. Nachdem ich in der tiefsten Rekursions-Ebene alle Dateien abgeackert hatte, bekam ich die Fehlermeldung:
Laufzeitfehler 5:
Ungültiger Prozeduraufruf oder ungültiges Argument

Hatte auch schon versucht den Fehler abzufangen, aber das brachte auch nichts. Naja, mein bisheriger Code: Code:

Public Sub readStructure(Path As String, Optional ParentID As Long)
Dim CurrentPath As String
Dim NewParentID As Long

CurrentPath = Dir(Path, vbDirectory)
Do
If CurrentPath "." And CurrentPath ".." Then
If GetAttr(Path & CurrentPath) = vbDirectory Then
If Not IsMissing(ParentID) Then
CodeDb.Execute "INSERT INTO PathStructure (ParentID,Path) VALUES (" & ParentID & _
", '" & Replace(CurrentPath, "'", "''") & "')", DB_FAILONERROR
Else
CodeDb.Execute "INSERT INTO PathStructure (Path) VALUES ('" & _
Replace(CurrentPath, "'", "''") & "')", DB_FAILONERROR
End If
NewParentID = DMax("DirectoryID", "PathStructure")
Call readStructure(Path & IIf(Right(Path, 1) = "\", "", "\") & _
CurrentPath & "\", NewParentID)
End If
End If
CurrentPath = Dir(, vbDirectory)
Loop Until CurrentPath = ""
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Der Tipp mit der Dir$-Funktion geht auch nicht VB 5/6-Tipp 0414: Ordner mit Dir$ rekursiv durchsuchen - ActiveVB

Toast78, 16. Februar 2012

#8
DAOLIX

daolix

Probiers mal so:
Code:

If (GetAttr(Path & CurrentPath) And vbDirectory) = vbDirectory Then
...
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Stand aber so ähnlich schon in der Antwrt von ios707

daolix, 16. Februar 2012

#9
TOAST78

Toast78

Oh, das hab ich wohl übersehen, dass ios707 das schon geschrieben hatte *rotwerd*

Toast78, 16. Februar 2012

#10
TOAST78

Toast78

Sooo! Habs auf die Kette bekommen.
Meine Version basiert jetzt eher auf der Breitensuche. Habe mich dabei an die Variante von http://www.arstechnica.de/index.html...a/vba0012.html

orientiert. Hier meine Lösung: Code:

Public Sub readStructure(Path As String, Optional ParentID As Long)
Dim CurrentPath As String
Dim NewParentID As Long
Dim SubDirs As Collection
Dim i As Long

Set SubDirs = New VBA.Collection
CurrentPath = Dir$(Path, vbDirectory)
Do
If CurrentPath "." And CurrentPath ".." Then
On Error Resume Next 'Diesen try-catch-Block brauchte ich, weil ich in
'einigen Dateien Zeichen gesehen hatte, die mir völlig neu waren.
'Diese Zeichen wurden dann im Debug-Fenster dann anders dargestellt
If GetAttr(Path & CurrentPath) And vbDirectory Then
If Err.Number = 0 Then
SubDirs.Add CurrentPath
Else
If Err.Number = 53 Then
MsgBox "Datei nicht gefunden: " & Path & CurrentPath, vbExclamation
End If
End If
End If
End If
CurrentPath = Dir$(, vbDirectory)
Loop Until CurrentPath = ""

For i = 1 To SubDirs.Count
If Not IsMissing(ParentID) Then
CodeDb.Execute "INSERT INTO PathStructure (ParentID, Path) VALUES (" & ParentID & _
", '" & Replace(SubDirs(i), "'", "''") & "')", DB_FAILONERROR
Else
CodeDb.Execute "INSERT INTO PathStructure (Path) VALUES ('" & _
Replace(SubDirs(i), "'", "''") & "')", DB_FAILONERROR
End If
NewParentID = DMax("DirectoryID", "PathStructure")
Call readStructure(Path & IIf(Right(Path, 1) = "\", "", "\") & _
SubDirs(i) & "\", NewParentID)
Next i
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Toast78, 16. Februar 2012

#11
GRZI

grzi

Gibt es einen Grund, warum du das nicht mit dem FSO löst?

Habe deine Lösung mal auf einen Folder mit ~400 SubFoldern getestet gegen eine strukturell gleich aufgebaute FSO-Lösung:
Dir-Version: 1,871094Sek.
FSO-Version: 0,84375Sek.

Deine Lösung erscheint mir nicht so arg performant... *wink.gif*
Beispiel kann ich dir bei Bedarf einstellen.

grzi, 16. Februar 2012

#12
TOAST78

Toast78

Dir(Path, vbDirectory) liefert Dateinamen

Oh okay. Auch interessant zu wissen. Hatte wesentlich länger gebraucht. Beim Einlesen meines Laufwerks mit 600 Verzeichnissen, habe ich ca. 10 Sekunden gebraucht.

Toast78, 16. Februar 2012

#13
GRZI

grzi

Habe meine Lösung auf Basis eines Arrays aufgebaut, kannst ja mal testen wie das mit einer Collection aussieht!

Hier zum testen - oder wegschauen und erst mal selbst probieren *wink.gif*
Code:

'---------------------------------------------------------------------------------------
' Procedure : StructureRead
' Author : GRZI
' Date : 17.02.2012
' Purpose : ReadStructure Ersatz: FSO anstatt Dir-Anweisung
' Linked : ListSubFolder
'---------------------------------------------------------------------------------------
'
Public Sub StructureRead(path As String, Optional ParentID As Long)
Dim CurrentPath As String
Dim NewParentID As Long
Dim arrFolder() As String
Dim i As Integer

On Error GoTo gtoErrHdl
If path = vbNullString Then Exit Sub
arrFolder = Split(ListSubFolder(path), ":")

For i = LBound(arrFolder) To UBound(arrFolder)
If Not IsMissing(ParentID) Then
CodeDb.Execute "INSERT INTO PathStructure (ParentID, Path) VALUES (" & ParentID & _
", '" & Replace(arrFolder(i), "'", "''") & "')", DB_FAILONERROR
NewParentID = DMax("DirectoryID", "PathStructure")
Call StructureRead(path & IIf(Right(path, 1) = "\", "", "\") & _
arrFolder(i) & "\", NewParentID)
Else
CodeDb.Execute "INSERT INTO PathStructure (Path) VALUES ('" & _
Replace(arrFolder(i), "'", "''") & "')", DB_FAILONERROR
NewParentID = DMax("DirectoryID", "PathStructure")
Call StructureRead(path & IIf(Right(path, 1) = "\", "", "\") & _
arrFolder(i) & "\", NewParentID)
End If
Next

Exit Sub

gtoErrHdl:
Select Case Err.Number

Case 70 'Keine Zugriff-Erlaubnis!
Resume Next
Case 424 'Objekt erforderlich - z.B. kein Subfolder
Resume Next
Case 92 'For-Schleife nicht initialisiert - kann nach 424 auftreten!
Resume Next
Case Else
Debug.Print Err.Number & " - " & Err.Description
Resume Next
End Select

End Sub

'---------------------------------------------------------------------------------------
' Procedure : ListSubFolder
' Author : GRZI
' Date : 16.02.2011
' Purpose : Liefert die erste Ebene an SubFoldern eines Verzeichnisses
'---------------------------------------------------------------------------------------
'
Public Function ListSubFolder(ByVal sFolder As String) As String
Dim objFSO As Object
Dim Folder As Object
Dim SubFolder As Object
Dim sErg As String
On Error GoTo gtoErrHdl
sErg = vbNullString

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = objFSO.GetFolder(sFolder)

For Each SubFolder In Folder.SubFolders
sErg = sErg & ":" & SubFolder.Name
Next

Set objFSO = Nothing
Set Folder = Nothing

'Ergebnis übergeben und 1. ":" abschneiden
ListSubFolder = Mid$(sErg, 2)
Exit Function

gtoErrHdl:
Select Case Err.Number

Case 70 'Keine Zugriff-Erlaubnis!
Exit Function 'Resume Next
Case 424 'Objekt erforderlich - z.B. kein Subfolder
Resume Next
Case 92 'For-Schleife nicht initialisiert - kann nach 424 auftreten!
Resume Next
Case Else
Debug.Print Err.Number & " - " & Err.Description & " in ListSubFolder"
Resume Next
End Select
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Zum Stoppen der Zeit:
Code:

Sub Stoppen(ByVal path As String)
Dim first As Single
Dim second As Single

first = Timer
readStructure path
first = Timer - first

Debug.Print "Dir-Version: " & first & "Sek."
second = Timer
StructureRead path
second = Timer - second
Debug.Print "FSO-Version: " & second & "Sek."

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Viel Spass!

hier noch die Reference für das FSO: http://msdn.microsoft.com/en-us/libr...(v=vs.84).aspx

grzi, 16. Februar 2012

#14
GRZI

grzi

Zur Komplettierung und um die Messungen Fair zu halten, muss bei beiden Varianten dafür gesorgt werden, dass auch die Ergebnisse überein stimmen!

Zu Zwei ist mir noch eine leichte Performance-Verbesserung gelungen, die ich nicht vorenthalten möchte. Diese betrifft allerdings nur bedingt kleine Datenmengen (darunter verstehe ich bis ~2Tsd)!

Code:

'---------------------------------------------------------------------------------------
' Procedure : StrucRead
' Author : GRZI
' Date : 17.02.2012
' Purpose : StrucRead Ersatz: FSO anstatt für Dir-Anweisung
' Linked : isFolder
'---------------------------------------------------------------------------------------
Public Sub StrucRead(ByVal path As String, Optional ByVal ParentID As Long = 0)
Dim CurrentPath As String
Dim NewParentID As Long
Dim Folders As Object
Dim subFolder As Object
Dim lFolders As Long
Dim i As Integer

Dim objFSO As Object
Dim Folder As Object

If path = vbNullString Then Exit Sub

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = objFSO.GetFolder(path)

On Error GoTo gtoErrHdl

'Bringt die Performance voran!
If Folder.subFolders.Count = 0 Then Exit Sub
For Each subFolder In Folder.subFolders
'SystemFolder, Hidden oder beides!
If isFolder(subFolder) Then
If ParentID > 0 Then
CodeDb.Execute "INSERT INTO PathStructure (ParentID, Path) VALUES (" & ParentID & _
", '" & Replace(subFolder.Name, "'", "''") & "')", DB_FAILONERROR
NewParentID = DMax("DirectoryID", "PathStructure")
StrucRead subFolder.path, NewParentID
Else
CodeDb.Execute "INSERT INTO PathStructure (Path) VALUES ('" & _
Replace(subFolder.Name, "'", "''") & "')", DB_FAILONERROR
NewParentID = DMax("DirectoryID", "PathStructure")
StrucRead subFolder.path, NewParentID
End If
Else
'Debug.Print subFolder.Attributes
End If
Next

Set objFSO = Nothing
Set Folder = Nothing

Exit Sub

gtoErrHdl:
Select Case Err.Number

Case 70 'Keine Zugriff-Erlaubnis!
Resume Next
Case 424 'Objekt erforderlich - z.B. kein Subfolder
Resume Next
Case 92 'For-Schleife nicht initialisiert - kann nach 424 auftreten!
Resume Next
Case Else
Debug.Print Err.Number & " - " & Err.Description
Resume Next
End Select

End Sub

'---------------------------------------------------------------------------------------
' Procedure : isFolder
' Author : GRZI
' Date : 17.02.2012
' Purpose : Ermittlung ob das "Folder-Kriterium" gegeben ist
'---------------------------------------------------------------------------------------
'
Function isFolder(ByRef Folder As Object) As Boolean
'Constant Value Description
'Normal 0 Normal file. No attributes are set.
'ReadOnly 1 Read-only file. Attribute is read/write.
'Hidden 2 Hidden file. Attribute is read/write.
'System 4 System file. Attribute is read/write.
'volume 8 Disk drive volume label. Attribute is read-only.
'directory 16 Folder or directory. Attribute is read-only.
'Archive 32 File has changed since last backup. Attribute is read/write.
'Alias 1024 Link or shortcut. Attribute is read-only.
'Compressed 2048 Compressed file. Attribute is read-only.

Select Case Folder.Attributes
Case 16, 17, 24, 48, 2064 '18,20,50,52,2066,2068
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

grzi, 17. Februar 2012

#15

(Du musst angemeldet oder registriert sein, um eine Antwort erstellen zu können.)

Seite 1 von 2

Thema:

Dir(Path, vbDirectory) liefert Dateinamen

Die Seite wird geladen...

Dir(Path, vbDirectory) liefert Dateinamen - Similar Threads - Path vbDirectory liefert
Suche liefert keine Ergebnisse
in Microsoft Outlook Hilfe
Suche liefert keine Ergebnisse: Ich nutze Windows 11 Home mit Outlook 2007, wo ich zwei IMAP-Postfächer eingebunden habe. Die Suche im Posteingang liefert keine Ergebnisse, egal welche Wörter eingebe. Ich habe die Indizierung...
Suchfunktion liefert KEIN Ergebnis
in Microsoft Outlook Hilfe
Suchfunktion liefert KEIN Ergebnis: Hallo, ich bräuchte mal Eure Hilfe ... Bei mir funktioniert die Suchfunktion in Outlook 365 so überhaupt nicht. Egal was ich für ein Wort eingebe ... kommt immer keine Ergebnisse Indizierung...
Makro um "wer liefert was" einzulesen
in Microsoft Excel Hilfe
Makro um "wer liefert was" einzulesen: Hallo liebes Forum, momentan mache ich ein Praktikum in einer Firma. Wie es als Praktikant so üblich ist, bekommt man da die Arbeit, die sonst keiner machen will. In meinem Fall ist das jetzt 4000...
DoCmd RunSql liefert Fehler in einer Funktion
in Microsoft Access Hilfe
DoCmd RunSql liefert Fehler in einer Funktion: Hallo Leute. Mit der folgenden Code in "Private Sub" gibt es kein Problem. Alles läuft super. Ich bruche diesen Code als Function, damit ich es aus einem Makro ausführen lassen möchte (oder...
Automatische Antowrt an "Reply-To" anstelle "Return-Path"
in Microsoft Outlook Hilfe
Automatische Antowrt an "Reply-To" anstelle "Return-Path": Grüße, ich habe die Google Suche als auch die Foren Suche erfolglos versucht, daher ein neuer Eintrag. Folgendes Problem: ich möchte emails automatisch mit einer Vorlage beantworten, jedoch...
Docmd.TransferText liefert Fehler 2046 Der Befehl oder die Aktion steht momentan...
in Microsoft Access Hilfe
Docmd.TransferText liefert Fehler 2046 Der Befehl oder die Aktion steht momentan...: Hallo zusammen, ich verwende den Befehl Docmd.TransferText. Dieser liefert zeitweise den Laufzeitfehler 2046 "Der Befehl oder die Aktion TransferText' steht momentan nicht zur Verfügung."...
Array-Formel liefert #WERT! - Brauche Hilfe!
in Microsoft Excel Hilfe
Array-Formel liefert #WERT! - Brauche Hilfe!: Ich habe folgende Array-Formel, die allerdings kein Ergebnis liefert, sondern #WERT! als Fehlermeldung liefert:...

Anmelden oder registrieren

Suche

Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.

Akzeptieren Weitere Informationen...

Information ausblenden