VBA Dateieigenschaften auslesen

Guten Morgen Zusammen,

ich brauch mal wieder eure Hilfe.

Mein Vorhaben ist das ich bei allen gefundenen Excel Dateien die Dateieigenschaft Titel, Autor, Erstelldatum und Letzte Änderung herauslese und in die Vorgesehen Spalten schreibe. (C2:F2). Ich habe einen Code gefunden nur das Problem ist das er mir immer mein aktives Dokument ausließt und nicht die gefundenen. Ich weiß auch ehrlich gesagt nicht wie ich des hinbekommen soll. Gibt es die Möglichkeit die Gefundenen Dateien geschlossen zu haben und trotzdem an die Eigenschaften dran zu kommen?
Für Tipps wäre ich sehr Dankbar.

Hier ist noch mein Quellcode:

Auslesen der Datei Eigenschaften versuche ich in der Sub ReadDocumentProperties()

Option Compare Text 'benötigt für einen 'like' Vergleich  

Dim fso As Object 'Variable ganz am Anfang des Codefensters stehen lassen !  
Dim objFoundFiles As New Collection

Sub SearchForAll()
'Variablen Deklarieren  
Dim strFolderPath As String

Dim lngRow As Long, lngRet As Long, lngCounter As Long, lngBreak As Long, lngMaxData As Long
Dim f As Variant
Dim rngOut As Range

'Werte setzten  
 lngCounter = 0
 lngBreak = 50000
 
'FilesystemObject erstellen  
Set fso = CreateObject("Scripting.Filesystemobject")  
    'Sheet Output wechseln  
    Worksheets("Output").Activate  
    With ActiveSheet
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen  
        Set rngOut = .Range("A2")  
        
        'Sheet ab Range-Paste vor Import gegebenenfalls bereinigen  
        If .UsedRange.Rows.Count >= rngOut.Row Then
            .Rows(rngOut.Row & ":" & .UsedRange.Rows.Count + 1).Clear  
        End If
    End With
'Headline erstellen Subaufruf  
Call headline

'Button erstellen  

'Ordner Verzeichnis auswählen  
 strFolderPath = fncBrowseForFolder

'Suche Dateien mit passenden Namen  
    enumFiles fso.GetFolder(strFolderPath), objFoundFiles
    
    ' Prüfen ob Daten gefunden wurden  
    If objFoundFiles.Count > 0 Then
        'Max Daten Wert zuordnen  
        lngMaxData = objFoundFiles.Count
        'Worksheet Tabelle auswählen  
        Worksheets("Output").Activate  
   'Für jede gefundene Datei in der Collection  
        For Each f In objFoundFiles
            strPathName = fso.GetParentFolderName(f)
            strFileName = fso.GetFileName(f)
            'Sucht nächste Freie Zeile  
            lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            'Gibt die Datei informationen aus  
              Cells(lngRow, 1) = strPathName
              Cells(lngRow, 2) = strFileName
            'Regelt die Zähler und Abbruchkriterien  
            lngMaxData = lngMaxData - 1
            lngCounter = lngCounter + 1
            If lngCounter >= lngBreak Then
                If MsgBox("Sollen weitere Pfade Angezeigt werden?", vbYesNo) = vbYes Then  
                    lngBreak = lngBreak + 10
                Else
                    Exit For
                End If
            ElseIf lngMaxData = 0 Then
                MsgBox "Es sind keine Daten mehr vorhanden!"  
                Exit For
            End If
        Next
     'Dateieigenschaften  
     Call ReadDocumentProperties
    End If
End Sub

'Auslesen der Datei Eigenschaften  
Sub ReadDocumentProperties()
   Dim iRow As Integer
   'Neue Tabelle erstellen  
   'Worksheets.Add before:=Worksheets(1)  
   'Zeile = 1  
   
   On Error Resume Next
   'Aktuelle Tabelle  
   With ActiveWorkbook.BuiltinDocumentProperties
      iRow = 0
      'Solange zählen bis Eigenschaften durch sind  
      For Each f In objFoundFiles
        iRow = iRow + 1
        'Ausgabe der Eigenschaften in Entsprechender Zelle  
         Cells(iRow + 1, 3).Value = .Item(1).Value
         Cells(iRow + 1, 4).Value = .Item(3).Value
         Cells(iRow + 1, 5).Value = .Item(11).Value
         Cells(iRow + 1, 6).Value = .Item(12).Value
         'Fehlermeldung falls Err.Number ungleich 0 ist  
         'If Err.Number <> 0 Then  
          '  Cells(iRow + 3, 2).Value = CVErr(xlErrNA)  
           ' Err.Clear  
         'End If  
      Next
      
   End With
   On Error GoTo 0
   Set objFoundFiles = Nothing
End Sub

Gruß Gimli3311

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 264976

Url: https://administrator.de/contentid/264976

Ausgedruckt am: 27.11.2024 um 04:11 Uhr

9 Kommentare

Neuester Kommentar

Wie das ohne ein File zu öffnen geht, kannst du hier nachlesen:
VB Script gesucht um Videodateien auslesen zu können.

Gruß jodel32

Hallo Gimli3311,
wie @114757 bereits verlinkt hat lässt sich das ohne die Files zu öffnen machen:

Hier das Beispiel für deine oben genannten Datei-Eigenschaften:

'Benötigte Objekte  
Set objShell = CreateObject("Shell.Application")  
Set fso = CreateObject("Scripting.Filesystemobject")  

'Pfad der Datei  
strFilePath = "C:\temp\demo.xlsx"  

'Eigenschaften mit Funktion auslesen und Variablen zuweisen  
strAutoren = GetFileProperty(strFilePath,20)
strTitle = GetFileProperty(strFilePath,21)
strDateModified = GetFileProperty(strFilePath,3)
strDateCreated = GetFileProperty(strFilePath,4)

' Nur zur Demo die Eigenschaften ausgeben  
MsgBox strFilePath & vbNewLine & strAutoren & vbNewLine & strTitle & vbNewLine & strDateModified & vbNewLine & strDateCreated

Function GetFileProperty(strFile,intProperty)
	Set nsFolder = objShell.NameSpace(fso.GetParentFolderName(strFile))
	Set file = nsFolder.ParseName(fso.GetFileName(strFile))
	GetFileProperty = nsFolder.GetDetailsOf(file,intProperty)
End Function

Denke damit solltest du es problemlos in dein Script integrieren können.

Die Nummern der Dateieigenschaften können sich je nach Betriebssystem unterscheiden, ich habe dir hier mal die eines Windows 7 aufgelistet:

- Name
- Größe
- Elementtyp
- Änderungsdatum
- Erstelldatum
- Letzter Zugriff
- Attribute
- Offlinestatus
- Offline verfügbar
- Erkannter Typ
- Besitzer
- Art
- Aufnahmedatum
- Mitwirkende Interpreten
- Album
- Jahr
- Genre
- Dirigenten
- Markierungen
- Bewertung
- Autoren
- Titel
- Thema
- Kategorien
- Kommentare
- Copyright
- Titelnummer
- Länge
- Bitrate
- Geschützt
- Kameramodell
- Abmessungen
- Kamerahersteller
- Firma
- Dateibeschreibung
- Programmname
- Dauer
- Ist online
- Periodisch wiederkehrend
- Ort
- Adressen der optionalen Teilnehmer
- Optionale Teilnehmer
- Organisatoradresse
- Organisatorname
- Erinnerungszeit
- Adressen der erforderlichen Teilnehmer
- Erforderliche Teilnehmer
- Ressourcen
- Besprechungsstatus
- Status frei/besetzt
- Gesamtgröße
- Kontoname
- Aufgabenstatus
- Computer
- Jahrestag
- Name des Assistenten
- Telefonnummer des Assistenten
- Geburtstag
- Geschäftsadresse
- Ort (geschäftlich)
- Land/Region (geschäftlich)
- Postfach (geschäftlich)
- Postleitzahl (geschäftlich)
- Bundesland/Kanton (geschäftlich)
- Straße (geschäftlich)
- Fax (geschäftlich)
- Homepage (geschäftlich)
- Rufnummer (geschäftlich)
- Rückrufnummer
- Autotelefon
- Kinder
- Zentrale Firmenrufnummer
- Abteilung
- E-Mail-Adresse
- E-Mail2
- E-Mail3
- E-Mail-Liste
- E-Mail-Anzeigename
- Speichern unter
- Vorname
- Vollständiger Name
- Geschlecht
- Gegebener Name
- Hobbies
- Privatadresse
- Ort (privat)
- Land/Region (privat)
- Postfach (privat)
- Postleitzahl (privat)
- Bundesland/Kanton (privat)
- Straße (privat)
- Fax (privat)
- Rufnummer (privat)
- IM-Adressen
- Initialen
- Position
- Bezeichnung
- Nachname
- Adresse
- Zweiter Vorname
- Mobiltelefon
- Spitzname
- Bürostandort
- Weitere Adresse
- Andere Stadt
- Anderes Land/Region
- Anderes Postfach
- Andere Postleitzahl
- Anderes Bundesland bzw. Kanton
- Andere Straße
- Pager
- Persönlicher Titel
- Stadt
- Land/Region
- Postfach
- Postleitzahl
- Bundesland/Kanton
- Straße
- Primäre E-Mail
- Primäre Telefonnummer
- Beruf
- Ehepartner/Partner
- Suffix
- TTY/TTD-Telefon
- Telex
- Webseite
- Inhaltstatus
- Inhaltstyp
- Erfassungsdatum
- Archivierungsdatum
- Vollendungsdatum
- Gerätekategorie
- Verbindung hergestellt
- Erkennungsmethode
- Anzeigename
- Lokaler Computer
- Hersteller
- Modell
- Paarweise
- Klassifizierung
- Gerätestatus
- Clientkennung
- Mitwirkende
- Inhalt erstellt
- Zuletzt gedruckt
- Letzte Speicherung
- Hauptabteilung
- Dokument-ID
- Seiten
- Folien
- Gesamtbearbeitungszeit
- Wortanzahl
- Fällig am
- Enddatum
- Dateianzahl
- Dateiname
- Dateiversion
- Kennzeichnungsfarbe
- Kennzeichnungsstatus
- Freier Speicherplatz
- Bittiefe
- Horizontale Auflösung
- Breite
- Vertikale Auflösung
- Höhe
- Wichtigkeit
- Anlage?
- Ist gelöscht
- Verschlüsselungsstatus
- Kennzeichnung vorhanden
- Wurde beendet
- Unvollständig
- Lesestatus
- Freigegeben
- Ersteller
- Datum
- Ordnername
- Ordnerpfad
- Ordner
- Teilnehmer
- Pfad
- Nach Ort
- Typ
- Kontaktnamen
- Eintragstyp
- Sprache
- Letzter Besuch
- Beschreibung
- Verknüpfungsstatus
- Verknüpfungsziel
- URL
- Medium erstellt
- Veröffentlichungsdatum
- Codiert durch
- Produzenten
- Herausgeber
- Untertitel
- Benutzerweb-URL
- Texter
- Anlagen
- BCC-Adressen
- BCC
- CC-Adressen
- CC
- Unterhaltungs-ID
- Empfangsdatum
- Absendungsdatum
- Von Adressen
- Von
- Hat Anlagen
- Absenderadresse
- Absendername
- Speicher
- Empfängeradressen
- Arbeitstitel
- An
- Laufzeit
- Albuminterpret
- Album-ID
- Beats pro Minute
- Komponisten
- Ursprünglicher Schlüssel
- Bestandteil einer Kompilation
- Stimmung
- Teil eines Satzes
- Zeitraum
- Farbe
- Jugendschutz
- Grund für Jugendschutzeinstufung
- Verwendeter Speicherplatz
- EXIF-Version
- Ereignis
- Lichtwert
- Belichtungsprogramm
- Belichtungszeit
- Blendenzahl
- Blitzlichtmodus
- Brennweite
- 35mm Brennweite
- ISO-Filmempfindlichkeit
- Objektivhersteller
- Objektivmodell
- Lichtquelle
- Maximale Blende
- Messmodus
- Ausrichtung
- Personen
- Programmmodus
- Sättigung
- Abstand
- Weißausgleich
- Priorität
- Projekt
- Kanal
- Folgenname
- Untertitel (Closed Captions)
- Wiederholung
- Zweikanalton
- Sendungsdatum
- Sendungsbeschreibung
- Aufnahmezeit
- Senderrufzeichen
- Fernsehsendername
- Zusammenfassung
- Schnipsel
- Automatische Zusammenfassung
- Suchrelevanz
- Sensitivität
- Freigegeben für
- Freigabestatus
- Produktname
- Produktversion
- Supportlink
- Quelle
- Startdatum
- Abrechnungsinformationen
- Abgeschlossen
- Aufgabenbesitzer
- Gesamtdateigröße
- Marken
- Videokomprimierung
- Regisseure
- Datenrate
- Bildhöhe
- Einzelbildrate
- Bildbreite
- Gesamtbitrate
- 
- 
- 
- 
- CMYK Profile
- Primary color mode
- Colors
- Effects
- External bitmaps
- Fills
- Fonts used
- Fonts embedded
- Grayscale Profile
- Languages

Für alle die sich so eine Liste selber für Ihr OS generieren möchten hier ein kleines VB-Skript das eine Textdatei (Eigenschaften-Liste.txt) mit den Eigenschaftennamen und deren Nummern enthält:

Const LISTE = "Eigenschaften-Liste.txt"  
Set objShell = CreateObject("Shell.Application")  
Set nsFolder = objShell.NameSpace("C:\")  
strProps = ""  
For i = 0 To 400
	prop = nsFolder.GetDetailsOf(nsFolder.Items,i)
	If prop <> "" Then  
		strProps = strProps & Right("00" & i,3) & " - " & prop & vbNewLine  
	End If
Next
CreateObject("Scripting.FileSystemObject").OpenTextFile(LISTE,2,True).Write(strProps)  

Grüße Uwe

Danke Jodel32 für den Link und Danke Uwe für den Quellcode
Sitz jetzt glaub schon 3h dran und es geht immer noch nicht ^^ aber hab erst jetzt den Quellcode von dir Uwe gesehen.
Werde es nochmal versuchen und mein Ergebnis melden.

Danke

So ich hab es mal zusammen gebastelt.

Bekomme in der Funktion GetFileProperty(strFile, intProperty) eine Fehlermeldung (Zeile 88): Objekt Fehlt
Könntet ihr mir weiterhelfen?

Option Compare Text 'benötigt für einen 'like' Vergleich  

Dim fso As Object 'Variable ganz am Anfang des Codefensters stehen lassen !  
Dim objFoundFiles As New Collection

Sub SearchForAll()
'Variablen Deklarieren  
Dim strFolderPath As String

Dim lngRow As Long, lngRet As Long, lngCounter As Long, lngBreak As Long, lngMaxData As Long
Dim f As Variant
Dim rngOut As Range
Dim objFile As Object
Dim objShell As Object


Set objShell = CreateObject("Shell.Application")  

'Werte setzten  
 lngCounter = 0
 lngBreak = 50000
 
'FilesystemObject erstellen  
Set fso = CreateObject("Scripting.Filesystemobject")  
    'Sheet Output wechseln  
    Worksheets("Output").Activate  
    With ActiveSheet
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen  
        Set rngOut = .Range("A2")  
        
        'Sheet ab Range-Paste vor Import gegebenenfalls bereinigen  
        If .UsedRange.Rows.Count >= rngOut.Row Then
            .Rows(rngOut.Row & ":" & .UsedRange.Rows.Count + 1).Clear  
        End If
    End With
'Headline erstellen Subaufruf  
Call headline

'Button erstellen  

'Ordner Verzeichnis auswählen  
 strFolderPath = fncBrowseForFolder

'Suche Dateien mit passenden Namen  
    enumFiles fso.GetFolder(strFolderPath), objFoundFiles

    ' Prüfen ob Daten gefunden wurden  
    If objFoundFiles.Count > 0 Then
        'Max Daten Wert zuordnen  
        lngMaxData = objFoundFiles.Count
        'Worksheet Tabelle auswählen  
        Worksheets("Output").Activate  
   'Für jede gefundene Datei in der Collection  
        For Each f In objFoundFiles
            strPathName = fso.GetParentFolderName(f)
            strFileName = fso.GetFileName(f)
            strFullPathFileName = strPathName & "\" & strFileName  
            strAutoren = GetFileProperty(strFullPathFileName, 20)
            strTitle = GetFileProperty(strFullPathFileName, 21)
            strDataModified = GetFileProperty(strFullPathFileName, 3)
            strDataCreated = GetFileProperty(strFullPathFileName, 4)
            'Sucht nächste Freie Zeile  
            lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            'Gibt die Datei informationen aus  
              Cells(lngRow, 1) = strPathName
              Cells(lngRow, 2) = strFileName
            ' Nur zur Demo die Eigenschaften ausgeben  
            MsgBox strFilePath & vbNewLine & strAutoren & vbNewLine & strTitle & vbNewLine & strDateModified & vbNewLine & strDateCreated
            'Regelt die Zähler und Abbruchkriterien  
            lngMaxData = lngMaxData - 1
            lngCounter = lngCounter + 1
            If lngCounter >= lngBreak Then
                If MsgBox("Sollen weitere Pfade Angezeigt werden?", vbYesNo) = vbYes Then  
                    lngBreak = lngBreak + 10
                Else
                    Exit For
                End If
            ElseIf lngMaxData = 0 Then
                MsgBox "Es sind keine Daten mehr vorhanden!"  
                Exit For
            End If
        Next
     'Dateieigenschaften  
     Call ReadDocumentProperties
    End If
End Sub
Function GetFileProperty(strFile, intProperty)
    Set nsFolder = objShell.Namespace(fso.GetParentFolderName(strFile))
    Set file = nsFolder.ParseName(fso.GetFileName(strFile))
    GetFileProperty = nsFolder.GetDetailsOf(file, intProperty)
End Function

Gruß Gimli3311

Du musst die Objekte objShell Global deklarieren und nicht lokal ! Also vor die SUB verschieben z.B. nach Zeile 5...
Sonst sind diese nur in der Sub und nicht in der Function verfügbar ... dort finden sie nämlich auch Verwendung ...

Option Compare Text 'benötigt für einen 'like' Vergleich  
Dim fso As Object, objShell as Object
Dim objFoundFiles As New Collection

Sub SearchForAll()
'Variablen Deklarieren  
Dim strFolderPath As String

Dim lngRow As Long, lngRet As Long, lngCounter As Long, lngBreak As Long, lngMaxData As Long
Dim f As Variant
Dim rngOut As Range
Dim objFile As Object

Set objShell = CreateObject("Shell.Application")  
Set fso = CreateObject("Scripting.Filesystemobject")  

'Werte setzten  
 lngCounter = 0
 lngBreak = 50000
 

    'Sheet Output wechseln  
    Worksheets("Output").Activate  
    With ActiveSheet
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen  
        Set rngOut = .Range("A2")  
        
        'Sheet ab Range-Paste vor Import gegebenenfalls bereinigen  
        If .UsedRange.Rows.Count >= rngOut.Row Then
            .Rows(rngOut.Row & ":" & .UsedRange.Rows.Count + 1).Clear  
        End If
    End With
'Headline erstellen Subaufruf  
Call headline

'Button erstellen  

'Ordner Verzeichnis auswählen  
 strFolderPath = fncBrowseForFolder

'Suche Dateien mit passenden Namen  
    enumFiles fso.GetFolder(strFolderPath), objFoundFiles

    ' Prüfen ob Daten gefunden wurden  
    If objFoundFiles.Count > 0 Then
        'Max Daten Wert zuordnen  
        lngMaxData = objFoundFiles.Count
        'Worksheet Tabelle auswählen  
        Worksheets("Output").Activate  
   'Für jede gefundene Datei in der Collection  
        For Each f In objFoundFiles
            strPathName = fso.GetParentFolderName(f)
            strFileName = fso.GetFileName(f)
            strAutoren = GetFileProperty(f, 20)
            strTitle = GetFileProperty(f, 21)
            strDataModified = GetFileProperty(f, 3)
            strDataCreated = GetFileProperty(f, 4)
            'Sucht nächste Freie Zeile  
            lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            'Gibt die Datei informationen aus  
              Cells(lngRow, 1) = strPathName
              Cells(lngRow, 2) = strFileName
              Cells(lngRow, 3) = strAutoren
              Cells(lngRow, 4) = strTitle
              Cells(lngRow, 5) = strDataModified
              Cells(lngRow, 6) = strDataCreated
            'Regelt die Zähler und Abbruchkriterien  
            lngMaxData = lngMaxData - 1
            lngCounter = lngCounter + 1
            If lngCounter >= lngBreak Then
                If MsgBox("Sollen weitere Pfade Angezeigt werden?", vbYesNo) = vbYes Then  
                    lngBreak = lngBreak + 10
                Else
                    Exit For
                End If
            ElseIf lngMaxData = 0 Then
                MsgBox "Es sind keine Daten mehr vorhanden!"  
                Exit For
            End If
        Next
     'Dateieigenschaften  
     Call ReadDocumentProperties
    End If
End Sub
Function GetFileProperty(strFile, intProperty)
    Set nsFolder = objShell.Namespace(fso.GetParentFolderName(strFile))
    Set file = nsFolder.ParseName(fso.GetFileName(strFile))
    GetFileProperty = nsFolder.GetDetailsOf(file, intProperty)
End Function

Ohje man merkt wir haben heut Montag ^^

Hätte des selber glaub nie gefunden :D Danke Jodel32 und Uwe

Gruß Gimli3311

Zitat von @colinardo:

>
Die Nummern der Dateieigenschaften können sich je nach Betriebssystem unterscheiden, ich habe dir hier mal die eines Windows
7 aufgelistet:

Können sich die Zahlen auch mit der Version von Excel unterscheiden?
Ich hab auf meinem Rechner hier Windows 7 und Excel 2013
Auf der VM ist auch Windows 7 drauf aber das Excel 2010

Wenn ich jetzt auf der VM teste bekomme ich den Autoren und Titel nicht angezeigt.
Die anderen Eigenschaften: Erstelldatum und Änderungsdatum stimmen aber.

Vielleicht hast du eine Erklärung für

Gruß Gimli3311

PS: Es liegt wirklich an der Excel Version, konnte es grad mit dem 2013 auf der VM testen

Zitat von @Gimli3311:
PS: Es liegt wirklich an der Excel Version, konnte es grad mit dem 2013 auf der VM testen

Nein, liegt nicht an der Excel-Version, sondern den installierten Patches, ist ein Bug
http://www.experts-exchange.com/Programming/Languages/.NET/Visual_Basic ...
Denn dann werden nur die ersten 8 Einträge zurückgegeben ...

Also wenn ich es mit Excel 2013 mache bekomme ich mehr als die ersten 8 Einträge raus.
Aber das es ein Bug gibt glaub ich dir gerne, bin nur froh das es bei mir jetzt geht :D

Gruß Gimli3311

gelöst Frage VB for Applications Entwicklung

Mehr von Gimli3311

ACCESS Hauptformular mit zwei Unterformularen - Fokus setztenGimli3311 - 1 Kommentar

VBA: workbook schließt sich nicht, wenn Sheet ein Diagramm istGimli3311 - 2 Kommentare

MsgBox Druckeinrichtung mit VBA abschaltenGimli3311 - 8 Kommentare

Xcopy Meldung UnterdrückenGimli3311 - 25 Kommentare

Heiß diskutiert