Dateiattribute auslesen

Hallo Zusammen, hallo Nepumuk,
Nepumuk, Du hast unter https://www.herber.de/forum/archiv/1792to1796/1794890_Dateiattribute_auslesen.html diesen wunderbaren CODE präsentiert. Er analysiert in einem Ordner die Dateien, also eigentlich deren Attribute.
DANKE hierfür. SUPER!!!!!
Ich habe Deinen CODE etwas erweitert... Bei mir kann man den Ordner auswählen und in Sheet(2) auswählen, welche Attribute ausgelesen/importiert werden sollen). Dadurch geht es schneller...
Nun würde ich aber gerne diesen CODE so anpassen, dass er auch die Unterordner mit deren Dateien und Ordnern ausliest...
Hat jemand eine Idee? IM Folgenden mein CODE
Vielen Dank und schöne Grüße
---
Option Explicit
Public lngIndex, Startzeile As Integer
Public Dateiname_des_Tools, Dateipfad_des_Tools, Temp_Datei_Pfad_und_Name, FOLDER_PATH As String


Sub Daten_Einlesen()
Dim objShell As Object
Dim Datei As Object
Dim objFolder As Object
Dim objFileDialog As FileDialog
Dim lngIndex As Long, i As Long, lngRow As Long
Dim vntFileName As Variant
' Damit die Datei an einem beliebigen Ort gespeichert und beliebig genannt werden kann, muss deren Name herausgelesen werden
Dateiname_des_Tools = ThisWorkbook.Name
Dateipfad_des_Tools = ThisWorkbook.Path
' Info, dass es nun dauern kann...
If MsgBox("Ordner wählen", vbOKCancel, "Attribute auslesen") = vbOK Then
' Wegen Überschriften
Startzeile = 5
' Alte Datenlöschen
Workbooks(Dateiname_des_Tools).Sheets(1).Rows(Startzeile & ":1000").Delete
' Ordner abfragen, der analysiert werden soll
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
If .Show = -1 Then
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(.SelectedItems(1))
i = 1
' Alle Spalten durchlaufen
Do Until lngIndex = 333
If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then
Worksheets(1).Cells(Startzeile, i) = objFolder.GetDetailsOf(Empty, lngIndex)
i = i + 1
End If
lngIndex = lngIndex + 1
Loop
Worksheets(1).Rows(Startzeile).Font.Bold = True
i = 1
lngIndex = 0
lngRow = 1
' Alle Zeilen d.h. Dateien durchlaufen
For Each vntFileName In objFolder.Items
Do Until lngIndex = 333
If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then
Worksheets(1).Cells(Startzeile + lngRow, i) = objFolder.GetDetailsOf(vntFileName, lngIndex)
i = i + 1
End If
lngIndex = lngIndex + 1
Loop
lngRow = lngRow + 1
lngIndex = 0
i = 1
Next
' Formatierungen
Columns.AutoFit
Set objFolder = Nothing
Set objShell = Nothing
MsgBox "FERTIG!", vbOKOnly
End If
End With
End If
End Sub


Function ordnerauswahl_neu(ByVal initF As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = initF
.Title = "Wählen Sie ein Verzeichnis aus"
.ButtonName = "Verzeichnis wählen"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
ordnerauswahl_neu = .SelectedItems(1)
Else
ordnerauswahl_neu = ""
End If
End With
End Function

Sheet(2) sieht so aus_
Index Attribute Auswahl
0 Name x
1 Größe
2 Elementtyp x
3 Änderungsdatum x
...

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public lngIndex, Startzeile As Integer Public Dateiname_des_Tools, Dateipfad_des_Tools, Temp_Datei_Pfad_und_Name, FOLDER_PATH As String Sub Daten_Einlesen() Dim objShell As Object Dim Datei As Object Dim objFolder As Object Dim objFileDialog As FileDialog Dim astrFolders() As String Dim vntFolder As Variant Dim lngIndex As Long, i As Long, lngRow As Long Dim vntFileName As Variant ' Damit die Datei an einem beliebigen Ort gespeichert und beliebig genannt werden kann, muss deren Name herausgelesen werden Dateiname_des_Tools = ThisWorkbook.Name Dateipfad_des_Tools = ThisWorkbook.Path ' Info, dass es nun dauern kann... If MsgBox("Ordner wählen", vbOKCancel, "Attribute auslesen") = vbOK Then ' Wegen Überschriften Startzeile = 5 ' Alte Datenlöschen Workbooks(Dateiname_des_Tools).Sheets(1).Rows(Startzeile & ":1000").Delete ' Ordner abfragen, der analysiert werden soll Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker) With objFileDialog If .Show Then Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(.SelectedItems(1)) astrFolders = GetFolders(.SelectedItems(1) & "\") 'hier kommt deine Suche nach den Dateien i = 1 ' Alle Spalten durchlaufen Do Until lngIndex = 333 If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then Worksheets(1).Cells(Startzeile, i) = objFolder.GetDetailsOf(Empty, lngIndex) i = i + 1 End If lngIndex = lngIndex + 1 Loop Worksheets(1).Rows(Startzeile).Font.Bold = True i = 1 lngIndex = 0 lngRow = 1 For Each vntFolder In astrFolders Set objFolder = objShell.Namespace(vntFolder) ' Alle Zeilen d.h. Dateien durchlaufen For Each vntFileName In objFolder.Items Do Until lngIndex = 333 If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then Worksheets(1).Cells(Startzeile + lngRow, i) = objFolder.GetDetailsOf(vntFileName, lngIndex) i = i + 1 End If lngIndex = lngIndex + 1 Loop lngRow = lngRow + 1 lngIndex = 0 i = 1 Next Next ' Formatierungen Columns.AutoFit Set objFolder = Nothing Set objShell = Nothing MsgBox "FERTIG!", vbOKOnly End If End With End If End Sub Private Function GetFolders(ByVal pvstrPath As String) As String() Dim astrFolders() As String Dim strFolder As String, strPath As String Dim ialngIndex1 As Long, ialngIndex2 As Long ReDim Preserve astrFolders(ialngIndex1) astrFolders(ialngIndex1) = pvstrPath ialngIndex1 = 1 ialngIndex2 = 1 strPath = pvstrPath Do strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory) Do Until strFolder = vbNullString If strFolder "." And strFolder ".." Then If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then ReDim Preserve astrFolders(0 To ialngIndex1) astrFolders(ialngIndex1) = strPath & strFolder & "\" ialngIndex1 = ialngIndex1 + 1 End If End If strFolder = Dir$ Loop If ialngIndex1 = ialngIndex2 Then Exit Do strPath = astrFolders(ialngIndex2) ialngIndex2 = ialngIndex2 + 1 Loop GetFolders = astrFolders End Function

Vielen herzlichen Dank!!! Wie immer von Dir... COOL und geht!!!
Noch einen Wunsch... ich bräuchte möglichst noch eine Abfrage, ob die Unterordner tatsächlich mit ausgelesen werden sollen... Verstehe deinen CODE...
For Each vntFileName In objFolder.Items
aber nicht so perfekt, dass ich da eingreifen kann. Hatte an eine einfache MsgBox gedacht, z.B.
if MsgBox("Dateien aus Unterordner auch analysieren?", ybyesno) = vbNo Then Exit For
... aber da springt er dann ja nicht aus beiden Schleifen raus, sondern nur aus der einen, so dass die Frage beim nächsten Unterordner wieder kommt... Und mit Sprungmarken soll man ja nicht abreiten, oder?
Bestimmt hast Du hier eine höchst elegante Lösung gleich in der Schleife selbst, etwa (wenn UserAbfrageMitUnterordner = True, dann schleife nur 1mal, sonst wie gehabt...)
VLG und nochmals 1000 DANK
P.S. Wie kann ich eigentlich in meinem Text hier CODE formatieren, damit es so hübsch aussieht?

Sub Daten_Einlesen() Dim objShell As Object Dim Datei As Object Dim objFolder As Object Dim objFileDialog As FileDialog Dim astrFolders() As String Dim vntFolder As Variant Dim lngIndex As Long, i As Long, lngRow As Long Dim vntFileName As Variant ' Damit die Datei an einem beliebigen Ort gespeichert und beliebig genannt werden kann, muss deren Name herausgelesen werden Dateiname_des_Tools = ThisWorkbook.Name Dateipfad_des_Tools = ThisWorkbook.Path ' Info, dass es nun dauern kann... If MsgBox("Ordner wählen", vbOKCancel, "Attribute auslesen") = vbOK Then ' Wegen Überschriften Startzeile = 5 ' Alte Datenlöschen Workbooks(Dateiname_des_Tools).Sheets(1).Rows(Startzeile & ":1000").Delete ' Ordner abfragen, der analysiert werden soll Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker) With objFileDialog If .Show Then Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(.SelectedItems(1)) If MsgBox("Dateien aus Unterordner auch analysieren?", vbQuestion Or vbYesNo) = vbNo Then ReDim astrFolders(0) astrFolders(0) = .SelectedItems(1) Else astrFolders = GetFolders(.SelectedItems(1) & "\") End If 'hier kommt deine Suche nach den Dateien i = 1 ' Alle Spalten durchlaufen Do Until lngIndex = 333 If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then Worksheets(1).Cells(Startzeile, i) = objFolder.GetDetailsOf(Empty, lngIndex) i = i + 1 End If lngIndex = lngIndex + 1 Loop Worksheets(1).Rows(Startzeile).Font.Bold = True i = 1 lngIndex = 0 lngRow = 1 For Each vntFolder In astrFolders Set objFolder = objShell.Namespace(vntFolder) ' Alle Zeilen d.h. Dateien durchlaufen For Each vntFileName In objFolder.Items Do Until lngIndex = 333 If Worksheets(2).Cells(lngIndex + 2, 3) = "x" Then Worksheets(1).Cells(Startzeile + lngRow, i) = objFolder.GetDetailsOf(vntFileName, lngIndex) i = i + 1 End If lngIndex = lngIndex + 1 Loop lngRow = lngRow + 1 lngIndex = 0 i = 1 Next Next ' Formatierungen Columns.AutoFit Set objFolder = Nothing Set objShell = Nothing MsgBox "FERTIG!", vbOKOnly End If End With End If End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread