Option Explicit
' --------------------------------------------------------- 
' Funktion: ReadExtendedInfos 
' Eingestellt von: Andre Schau 
' Datum: 5. Juno 2006 
' Kommentar: 
' Parameter: strPath, strFile und sType optional 
' Rückgabe: Erfolg: FileName, ansonsten False 
' Aufruf: 
Sub ReadExtendFileInfo()
' Ausgabebereich identisch, für unterschiedliche Bereiche 
' Parameter in Function erweitern! 
'Variablendeklarationen 
'Variant 
Dim OkFunction
'einzelnes File 
OkFunction = ReadExtendedInfos("C:\test\", "test1.txt")
'Verzeichnis 
OkFunction = ReadExtendedInfos("C:\test\")
End Sub
' --------------------------------------------------------- 
Private Function ReadExtendedInfos(ByVal strPath As Variant, _
        Optional ByVal strFile As Variant = "", _
        Optional ByVal sType As Variant = "") As Variant
ReadExtendedInfos = False
'Variablendeklarationen 
'Objektvariable 
Dim objShell As Object, objFolder As Object
'Integervariable 
Dim iCounter%, iRow%, iCol%
'Variable für Files 
Dim strFileName As Variant
'Arrayvariable - 34 Eigenschaften 
Dim arrHeaders(34)
'Flackern aus 
Application.ScreenUpdating = False
'Eingangsparameter prüfen 
If strFile <> "" And sType <> "" Then
  ReadExtendedInfos = "Bitte nur File oder Type angeben!"
  Exit Function
End If
'Pfad bei Bedarf Backslash hinzufügen 
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'Shell setzen 
Set objShell = CreateObject("Shell.Application")
'Ordner setzen 
Set objFolder = objShell.Namespace(strPath)
Set strFileName = objFolder.parsename(strFile)

'Schleifenvariablen festlegen 
iRow = 3 'Startzeile der Ausgabe 
iCol = 1 'Ausgabespalte 
'Bezeichner festlegen 
For iCounter = 0 To 33
  arrHeaders(iCounter) = objFolder.getdetailsof(objFolder, iCounter)
Next iCounter
If Not strFileName Is Nothing Then
For iCounter = 0 To 33
  Cells(iRow + iCounter, 1).Value = iCounter + 1
  Cells(iRow + iCounter, 2).Value = arrHeaders(iCounter)
  Cells(iRow + iCounter, 3).Value = _
     objFolder.getdetailsof(strFileName, iCounter)
Next iCounter
Else
For Each strFileName In objFolder.items
'Anzeige des Eigenschaftsdialoges 
'strFileName.invokeverb "E&igenschaften" 
  For iCounter = 0 To 33
    Cells(iRow + iCounter, 1).Value = iCounter + 1
    Cells(iRow + iCounter, 2).Value = arrHeaders(iCounter)
    Cells(iRow + iCounter, 3).Value = _
    objFolder.getdetailsof(strFileName, iCounter)
  Next iCounter
  iRow = iRow + 35 'Startzeile für nächste Datei 
Next strFileName
End If
'Flackern ein 
Application.ScreenUpdating = True
ReadExtendedInfos = True
End Function