Office: Verzeichnis auslesen

Früher konnten ich in Excel ein Windows-Explorer Verzeichnis mit allen Unterverzeichnissen auslesen und in einer Tabelle ablegen. Nun kommt die Fehlermeldung "brauche 64-Bit-Version"

Ich habe dann alles Mögliche versucht, finde jedoch keine Lösung. - Mein System Office 2016 und Windows 10.

Ich hoffe, dass mir nun jemand dieses VBA abändert, damit dies wieder funktioniert. Oder gibt es eine Version, die bereits besteht - und dazu noch mit Menüs, wo alle möglichen Parameter angegeben werden können? Auch dies gab es bereits schon - ein Herr Alfons Seeberger hatte dies soweit perfektioniert, dass sich keine weiteren Bedürfnisse mehr wecken liessen!

Zum VBA:
Option Explicit
'Typ für Windows-Dialogfeld zur Ordnersuche
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
'Folgenden Funktion benötigen wir zur Ermittlung des gewählten Laufwerks
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Dim Ordnername

Sub Einlesen()
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Dim Start As Long

Ordnername = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
If Ordnername = False Then Exit Sub
ChDir Ordnername
'Wir gehen eine Ebene nach oben, damit wir von dort in dieses erste Verzeichnis wechseln können
ChDir ".."
If Ordnername "" Then
Anzdateien = 0
Pfad1 = Ordnername 'Arbeitspfad merken
If Right(Ordnername, 1) "" Then Pfad1 = Pfad1 & ""
ReDim Verzeichnisse(0) 'Die Hauptebene wird das 0. Element
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)

Rekursion:
For i = Start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
Start = Start + 1
Obergrenze = UBound(Verzeichnisse)
GoTo Rekursion
Next
Anzordner = Obergrenze + 1 'Für Anzeige; da Array mit 0 beginnt, 1 dazu

'Lies in ein zweites Array alle Dateien aller gefundenen Verzeichnisse ein
'Damit das Dateien-Array auch entsprechend erweitert werden kann, übergeben wir
'die aktuelle Obergrenze als Startwert für neue Arrayelemente
For i = 1 To Obergrenze 'Wir beginnen bei 1, weil wir das Startverzeichnis nicht mit behandeln wollen
Suche_Dateien Verzeichnisse(i), UBound(Dateien)
Next

'War die Dateisuche erfolglos?
If UBound(Dateien) = 0 Then
If Len(Dateien(0)) = 0 Then
MsgBox "In keinem der " & Anzordner & " Ordner konnte eine Datei gefunden werden. " & vbCr & _
"Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Dateien"
End If
Else
'Wir nehmen die letzte Ebene, die ein leeres Feld enthält, wieder raus.
'Aber nur, wenn überhaupt Dateien vorhanden waren.
'Die Ebene wurde jeweils in Suche_Dateien erhöht.
ReDim Preserve Dateien(UBound(Dateien) - 1)
'Ab hier könnten natürlich sinnvoller Befehle folgen, als die Dateien nur aufzulisten...
For i = 0 To UBound(Dateien)
Cells(i + 1, 1).Value = Dateien(i)
Next
End If
End If
End Sub

Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
'Lies die Verzeichnisse in Pfad ein. Die Prozedur wird in OK_Click "rekursiv" aufgerufen,
'so dass wir ab einem Startverzeichnis eine Struktur einlesen können.
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory) ' Ersten Eintrag abrufen.
Do While Name1 "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 "." And Name1 ".." Then
'Ist die gefundene Datei ein Verzeichnis?
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & ""
End If
End If
Name1 = Dir 'Nächstes Verzeichnis finden
Loop
End Sub

Private Sub Suche_Dateien(ByVal Pfad As String, ByVal Arraygrenze As Long)
'Suche nach allen XL-Dateien im angegebenen Pfad
Dim Name2 As String
Name2 = Dir(Pfad & "*.xl*", vbNormal)
Do While Name2 ""
If (GetAttr(Pfad & Name2) And vbNormal) = vbNormal Then
ReDim Preserve Dateien(Arraygrenze + 1)
'Die Ebene, die wir hier vorsorglich schon mal erweitern, wird später wieder entfernt -
'aber erst ganz zum Schluss, wenn keine weiteren Dateien gefunden wurden.
Dateien(Arraygrenze) = Pfad & Name2
Arraygrenze = Arraygrenze + 1
Anzdateien = Anzdateien + 1
End If
Name2 = Dir()
Loop
End Sub

Private Function Ordnerwählen(ByVal strTitle As String) As String
'Stellt ein Windows-Dialogfeld zur Verfügung, mit dem sich ein beliebiger Ordner auswählen läßt.
'Entweder wird dieser oder (bei Abbruch) "" zurückgeliefert.
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function

:)

 

Hallo,

snb liefert die Instrumente (für einen Kulturkampf)

PHP:

         Private Declare Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Public Function F_ASC_ANS(ByVal Text As String) As String
OemToCharA Text, Text
F_ASC_ANS = Text
End Function

Sub M_snb()
Application.ScreenUpdating = False
sn = Split(F_ASC_ANS(CreateObject("wscript.shell").exec("cmd /c Dir ""V:xxxxxx*blabla*.xls"" /b/s").stdout.readall), vbCrLf)
cells(1,1).resize(ubound(sn) = sn
end sub


 

Hallo Fennek11

Herzlichen Dank für Ihre schnelle Antwort!

Nun habe ich allerdings zwei Probleme:

1. Von wo bis wo baue ich Ihre Vorgabe in das von mir einkopierte VBA ein - bzw. welche Zeilen muss ich genau ersetzen?

2. handelt es sich in meinem Fall um folgenden Pfad, welcher zu listen wäre: D:alles*.* oder eines der darin enthaltenden Unterverzeichnisse.

3. Wie nun sähe ihre Vorgabe ("cmd /c Dir ""V:xxxxxx*blabla*.xls"" /b/s") in diesem Falle aus? Was bedeutet /c /b /s ?

Bitte stellen Sie mir doch die richtige Abfolge der Befehle als fertiges Makro ein. Dies wäre dann - bis auf 3. - selbsterklärend. - Vielen Dank

mfg

 

Hallo,

Scherzfrage? Wer mit solchen API-Funktionen hantiert, der sollte auch snb's "wenig Zeiler" lesen können.

Der Code ist der alte DOS-Befehl:
cmd /c Schließen des Fensters nach Ende der Ausführung
/s alle Unterordner durchsuchen
/b einfaches Ausgabenformat

Wenn man nicht aufpasst (wie hier), "verschluckt" die Forensoftware die "backslashs", d.h. überall musss ein korrekter Pfad stehen.

Nach meinem Verständnis ersetzt der snb Code deinen API-Code vollständig.

mfg

(Meine Ironie war: Warum denn einen 3-Zeiler nutzen, wenn es auch mit 30 Zeilen geht. Das ist die Effizienz von PC's, derAufwand kann ins Unendliche gesteigert werden, der Nutzen ist ...)

 

nö, tut er nicht, der hat mit dem Apikram nix gemein, er ersetzt maximal nur die Suche der Dateien oder Ordner.

@rutzkinder
wenn du jetzt mit "Fehlermeldung "brauche 64-Bit-Version"" meinst das du Office 64bit einsetzt dann musst du die Deklarationen anpassen

Code:

sowie die von dir verwendeten Variablen welche auf die obigen Funktionen returnen.

 

Vielen Dank daolix
Ich habe Deine Vorgaben in mein Excel-VBA-Modul einkopiert. Alles scheint Ok bis auf die letzte Zeile - erschien in rot: Private Declare PtrSafe Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String
... wenn ich das Makro ausführen lassen will, geht jedoch auch nichts - ausser "Fehler beim Kompilieren".

Und dann - wenn ich Dich richtig verstanden habe - alle "32" auf 64 umgeschrieben, dann kam wieder dieselbe Fehlermeldung.

Wie mir scheint, habe ich vermeintlich den Eindruck eines stehen gebliebenen Experten hinterlassen. Leider habe ich keine Ahnung von der Materie. Die einkopierte Version habe ich nach Stundenlangem Suchen hier einkopiert ... nachdem meine Freude - endlich gefunden zu haben, was ich suchte, sehr schnell verblasste.

Kannst Du mir hierbei zu einer funktionierenden Listenfunktion verhelfen?

Liesse sich das der Einfachheit halber via Mail durchführen?

vielen Dank und Gruss

: josef

 

Hallo Josef,

da scheint beim kopieren des Codes etwas schief gelaufen zu sein. Da fehlt:

Code: