Dateieigenschaften auslesen
01.01.2021 08:27:20
Wolfgang
Steh mal wieder vor einem Problem
Habe 2 VBA codes:
der 1. listet mir Dateinamen und Verzeichnisse auf
der 2. listet Dateieigenschaften aus vordefiniertem Verzeichnis auf
=============================
Code1:
Sub Versuch_DateienAuflisten()
Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
'Dim strPfad
Set objFileSystem = CreateObject("scripting.FileSystemObject")
'strPfad = InputBox(Ordnerpfad)
'Set objVerzeichnis = objFileSystem.GetFolder(strPfad)
Set objVerzeichnis = objFileSystem.GetFolder(Worksheets("Dateiliste_Expert").Cells(1, 2).Value)
Set objDateienliste = objVerzeichnis.Files
lngZeile = 4
For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
ActiveSheet.Cells(lngZeile, 1) = objDatei.Name
lngZeile = lngZeile + 1
End If
Next objDatei
Call UnterOrdnerAuslesen(objVerzeichnis)
End Sub
Sub UnterOrdnerAuslesen(ByVal strDateipfad As String)
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objUnterordner As Object
Dim objDatei As Object
Dim i As Long
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(strDateipfad)
If Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Else
i = 4
End If
For Each objUnterordner In objVerzeichnis.subfolders
For Each objDatei In objUnterordner.Files
On Error Resume Next
If Not objDatei Is Nothing Then
' If Not objDatei Is Nothing And Not Right(objDatei.Name, 4) = ".jpg" Then
ActiveSheet.Cells(i, 1) = objDatei.Name
ActiveSheet.Cells(i, 2) = objUnterordner.Path
i = i + 1
End If
Next objDatei
Call UnterOrdnerAuslesen(objUnterordner.Path)
If Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Else
i = 1
End If
Next objUnterordner
End Sub
Sub Clear()
Range("A3:k999999").ClearContents
End Sub
Private Sub CommandButton1_Click()
Call Versuch_DateienAuflisten
End Sub
Private Sub CommandButton2_Click()
Call Clear
End Sub
===============================
code 2:
Public Sub Dateieigenschaften()
Const FOLDER_PATH As String = "D:\Music\" '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 300
Cells(1, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName, lngIndex)
Next
Rows(1).Font.Bold = True
lngRow = 2
For Each vntFileName In objFolder.Items
For lngIndex = 0 To 300
Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName, lngIndex)
Next
lngRow = lngRow + 1
Next
Columns.AutoFit
Application.ScreenUpdating = True
Set objFolder = Nothing
Set objShell = Nothing
End Sub
====================
Allerdings schaffe ich es nicht die Funktionen von Code 2 auf Code 1 umzuwälzen.
Ich hätte gerne dass bei code 1 ab Spalte 3 dann die Eigenschaften aufgelistet werden
die indizierung der Eigenschaften müsste folgendermaßen sein (würde mir gerne nur die rauspicken die ich brauche z.b. Spieldauer bei video oder Musikdateien...)
0 Name
1 Größe
2 Typ
3 Geändert am
4 Erstellt am
5 Letzter Zugriff am
6 Attribute
7 Status
8 Besitzer
9 Autor
10 Titel
11 Thema
12 Kategorie
13 Seiten
14 Kommentare
15 Copyright
16 Interpret
17 Albumtitel
18 Jahr
19 Titelnummer
20 Genre
21 Dauer
22 Bitrate
23 Geschützt
24 Kameramodell
25 Bild aufgenommen am
26 Abmessungen
27
28
29 Folgenname
30 Sendungsbeschreibung
31 Abtastgröße
32 Abtastrate
33 Kanäle
34 Firma
35 Beschreibung
36 Dateiversion
=====================
Hoffe jemand von euch hat des Rätsels lösung.
Besten Dank schonmal im Vorraus
Wolfgang