Dateiliste mit Eigenschaften

Hallo zusammen!
Ich möchte über VBA eine Liste mit Excel-Dateien in einem frei wählbaren Verzeichnis erstellen.
Das funktioniert ganz gut und ich kann in die Liste den Pfad, Dateinamen, Größe, .. eintragen.
wks.Cells(iCounter + 1, 3).Value = Left(.FoundFiles(iCounter), InStrRev(.FoundFiles(iCounter), "\") - 1) 'Pfad
wks.Cells(iCounter + 1, 4).Value = Mid(.FoundFiles(iCounter), _
InStrRev(.FoundFiles(iCounter), "\") + 1, Len(.FoundFiles(iCounter))) 'Dateiname
wks.Cells(iCounter + 1, 5).Value = FileLen(.FoundFiles(iCounter)) 'Dateigröße
wks.Cells(iCounter + 1, 6).Value = FileDateTime(.FoundFiles(iCounter)) 'letztes Speicherdatum
Gibt es eine Möglichkeit, den Code so zu erweitern, das auch weitere Dateieigenschaften in den
nächsten Spalten angezeigt werden, oder kann man auf die Dateieigenschaften nur in einer geöffneten
Datei zugreifen?
Vielen Dank schomal für Eure Anregungen
Dirk

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub ListAllFile() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim ws As Worksheet Set objFSO = CreateObject("Scripting.FileSystemObject") Set ws = Worksheets.Add 'Get the folder object associated with the directory !!! Hier das Laufwerk und den _ Verzeichnispfad setzen Set objFolder = objFSO.GetFolder("C:\") ' !!!! und hier noch die Zelle ab welcher die Dateinamen eingetragen werden sollen Cells( _ Zeile, Spalte) ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & "are:" 'Loop through the Files collection For Each objFile In objFolder.Files if lcase(right(objfile.name,3)) = "xls" then 'hier den Dateityp festlegen, falls 4stellig 3 auf 4 aendern!! ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name 'weitere eigenschaften: 'objFile.name 'objFile.Size 'objFile.Type 'objFile.DateCreated 'objFile.DateLastAccessed 'objFile.DateLastModified 'objFile.Attributes 'objFile.ShortPath 'objFile.ShortName end if Next 'Clean up! Set objFolder = Nothing Set objFile = Nothing Set objFSO = Nothing End Sub

Public Sub Dateieigenschaften() 'von K.Rola Const FOLDER_PATH As String = "D:\Eigene Dateien\Eigene Dokumente" Dim objShell As Object, objFolder As Object Dim intIndex As Integer, intColumn As Integer, lngRow As Long Dim varName If Dir(FOLDER_PATH, 16) = "" Then MsgBox "Der Ordner " & FOLDER_PATH & " wurde nicht gefunden!", 64, "Hinweis" Exit Sub End If Application.ScreenUpdating = False Cells.Clear Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(FOLDER_PATH) intColumn = 1 For intIndex = 0 To 255 Cells(1, intColumn + intIndex) = objFolder.GetDetailsOf(varName, intIndex) Next Rows(1).Font.Bold = True lngRow = 2 For Each varName In objFolder.Items For intIndex = 0 To 255 Cells(lngRow, intColumn + intIndex) = objFolder.GetDetailsOf(varName, intIndex) Next lngRow = lngRow + 1 Next Columns.AutoFit Application.ScreenUpdating = True End Sub

Hallo,
ein Beispiel zu weiterbasteln:


Public Sub Beispiel()
    
    Const FILE_FOLDER = "D:\Eigene Dateien\Eigene Tabellen\"
    Const FILE_PROPERTY = "Kommentare"
    Const FILE_NAME = "*.xls"
    Const MAX_PROPERTYS = 255
    
    Dim objShell As Object, objFolder As Object
    Dim strFile As String
    Dim lngIndex As Long, lngPosition As Long, lngRow As Long
    
    ' initialize errorhandler
    On Error GoTo error_exit
    
    ' verify folder exit
    If Dir$(FILE_FOLDER, vbDirectory) = "" Then _
        Err.Raise Number:=vbObjectError, Description:="Ordner ''" & FILE_FOLDER & "'' nicht gefunden."
    
    ' create object
    Set objShell = CreateObject(Class:="Shell.Application")
    
    ' set reverence to folder
    Set objFolder = objShell.Namespace((FILE_FOLDER))
    
    ' search position of fileproperty
    For lngIndex = 0 To MAX_PROPERTYS
        If Trim$(objFolder.GetDetailsOf("", lngIndex)) <> "" Then
            If Cbool(InStr(FILE_PROPERTY, objFolder.GetDetailsOf("", lngIndex))) Then
                lngPosition = lngIndex
                Exit For
            End If
        End If
    Next
    
    ' property not found - trigger an error
    If lngPosition = 0 Then _
        Err.Raise Number:=vbObjectError, Description:="Dateieigenschaft ''" & _
        FILE_PROPERTY & "'' nicht gefunden."
    
    ' get first file
    strFile = Dir$(FILE_FOLDER & FILE_NAME, vbNormal)
    
    ' loop over all files
    Do While strFile <> ""
        
        ' counter for rows in table
        lngRow = lngRow + 1
        
        ' write filename and property to table
        With Tabelle1
            .Cells(lngRow, 1).Value = strFile
            .Cells(lngRow, 2).Value = objFolder.GetDetailsOf( _
                objFolder.ParseName(strFile), lngPosition)
        End With
        
        ' get next file
        strFile = Dir$
        
    Loop
    
    Tabelle1.Columns.AutoFit
    
    sub_exit:
    
    ' clear objects
    Set objShell = Nothing
    Set objFolder = Nothing
    
    Exit Sub
    
    error_exit:
    
    ' show errormessage
    MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
    Resume sub_exit
    
End Sub

In Unterordner kommst du mit Dir$ natürlich nicht, aber dazu gibt es ja mehrere Alternativen.
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread