Hallo liebes Forum,

ich habe im Windowsexplorer Dateien gespeichert, die ich in Eigenschaften mit Kategorien, Betreff und Kommentar versehen habe. Weil es schon über 300 Dateien sind, möchte ich mir dafür in Excel eine Datenbank anlegen. Als Basis dafür muss ich die Dateien und die Attribute, Kategorien, Betreff und Kommentar neben dem Pfad und dem Namen auslesen. Nachdem ich den ganzen Tag herumexperimentiert habe (den Code habe ich mir im Internet zusammengesucht) bitte ich nun um Hilfe. Leider verändert sich der Dateiname in der Sub Dateieigenschaften() nicht.
Vielen Dank im Voraus

Hippolytus

Hier ist der Code:

Option Explicit

'Verweis auf die Microsoft Scripting Runtime Bibliothek --> Extras Verweise
Dim Kategorie As String
Dim Kommentar As String
Dim LetzteZeile As Long
Dim fso As New FileSystemObject
Dim Datei As File
Dim DateiAttribute As String
Dim Ordner As Variant
Dim Pfad As String


Sub AlleDateienauslesen()

'Variablen dimensionieren

Dim Ordner As Variant
Dim Pfad As String


'Pfad definieren

Pfad = ("F:\___Resolve\_Eigenes Tutorial\Einzel-Hinweise\Test") 'Ordner anpassen !!!

'neues Tabellenblatt erstellen

'Worksheets.Add
'alte Inhalte löschen

Cells.Clear

'Erste zeile auswählen

Cells.Rows("1").Select



'Überschriften eintragen

Range("A1:D1").Value = Array("Datei", "Ordner", "Kategorie", "Kommentar")


'Dateien des Ordner auslesen

Call DateienAuslesen(Pfad)

'Spaltenbreite einstellen

Columns("A:D").AutoFit

End Sub


Sub DateienAuslesen(Pfad As String)

'Variablen dimensionieren (fso = FileSystem Objekt)

Dim fso As New FileSystemObject
Dim Datei As File


'Schleife über alle dateien im Ordner

For Each Datei In fso.GetFolder(Pfad).Files

'letzte Zeile herausfinden

LetzteZeile = Cells(Rows.Count, 1).End(xlUp).Row + 1


'Alle Attribute auslesen

Dim DateiAttribute As String
' DateiAttribute


'Ergebnisse ins Tabellenblatt eintragen

ActiveSheet.Hyperlinks.Add anchor:=Cells(LetzteZeile, 1), Address:=Datei.Path, TextToDisplay:=Datei.Name

Cells(LetzteZeile, 1).Value = Datei.Name
Cells(LetzteZeile, 2).Value = Datei.ParentFolder
' Cells(LetzteZeile, 3).Value = Datei.Type
Dateieigenschaften

Next Datei

End Sub

Public Sub Dateieigenschaften()
Stop

Const FOLDER_PATH As String = "F:\___Resolve\_Eigenes Tutorial\Einzel-Hinweise\Test" 'Ordner anpassen !!!

Dim objShell As Object, objFolder As Object
Dim lngIndex As Long, lngColumn As Long, lngRow As Long
Dim vntFileName As Variant

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(FOLDER_PATH)

'Application.ScreenUpdating = False

'Cells.Clear

lngColumn = 1

'For lngIndex = 0 To 24
' Cells(1, lngColumn + lngIndex) = objFolder.GetDetailsOf(Empty, lngIndex)
'Debug.Print objFolder.GetDetailsOf(Empty, lngIndex)

'Next

Stop
Rows(1).Font.Bold = True
lngRow = LetzteZeile

For Each vntFileName In objFolder.Items
For lngIndex = 0 To 24
'Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName, lngIndex)

If lngColumn + lngIndex = 24 Then Cells(LetzteZeile, 3).Value = objFolder.GetDetailsOf(vntFileName, lngIndex)

If lngColumn + lngIndex = 25 Then Cells(LetzteZeile, 4).Value = objFolder.GetDetailsOf(vntFileName, lngIndex)

If lngColumn + lngIndex > 25 Then Exit For

'Debug.Print lngRow; lngColumn + lngIndex; objFolder.GetDetailsOf(vntFileName, lngIndex)

Next
' lngRow = lngRow + 1
If lngColumn + lngIndex Then Exit For
Next



Columns.AutoFit
'Application.ScreenUpdating = True

Set objFolder = Nothing
Set objShell = Nothing

End Sub