AW: Dateien per VBA auslesen
31.01.2019 20:25:07
fcs
Hallo Frieder,
man kann es dann wie folgt umsetzen, wenn nur bestimmte Eigenschaften angezeigt werden sollen.
LG
Franz
Sub Dateieigenschaften_alle()
Call Dateieigenschaften_0_bis_33("C:\Users\public\Documents", NrIndex:=True)
End Sub
Sub Dateiegen_schaften_medien()
Call Dateieigenschaften_0_bis_33("C:\Users\public\Documents", _
varEigenschaften:=Array(0, 3, 12, 13, 14, 15, 16, 17, 18), NrIndex:=False)
End Sub
Sub Dateieigenschaften_0_bis_33(ByVal STRFOLDER As Variant, Optional varEigenschaften As _
Variant, _
Optional NrIndex As Boolean = False)
'STRFOLDER: Ordner in dem die Eigenschaften der Dateien ausgelesen werden sollen
'varEigenschaften: Array mit den Index-Nummern der Eigenschaften, die ausgelesen werden sollen
'wird der parameter weggelassen, werden alle Eigenschaften ausgelesen
'NrIndex: optional, wenn True, dann werden in Zeile 1 die Index-Nrn der Eigenschaften _
ausgegeben
Dim objShell As Object, objFolder As Object
Dim x As Byte, intColumn As Integer, lngRow As Long
Dim varName, arrHeaders(34)
Dim varWert
If Dir(STRFOLDER, 16) = "" Then
MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin... _
Exit Sub
End If
On Error Resume Next
ActiveSheet.UsedRange.Clear
Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(STRFOLDER)
intColumn = 0
'Index-Nummer und Namen der Dateieigenschaften
For x = 0 To 33
If fncCheck(IIf(VBA.IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
intColumn = intColumn + 1
arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
If NrIndex = True Then
Cells(1, intColumn) = x
Cells(2, intColumn) = arrHeaders(x)
Else
Cells(1, intColumn) = arrHeaders(x)
End If
End If
Next
If NrIndex = True Then
Rows(2).Font.Bold = True
lngRow = 3
Else
Rows(1).Font.Bold = True
lngRow = 2
End If
For Each varName In objFolder.Items
intColumn = 0
For x = 0 To 33
If fncCheck(IIf(IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
intColumn = intColumn + 1
varWert = ""
varWert = objFolder.GetDetailsOf(varName, x)
Select Case x
Case 3, 4, 5 'Datum Zeit
If IsDate(varWert) Then varWert = CDate(varWert)
Case 12 'Aufnahmedatum (enthält sonderzeichen deshalb keine echtes Exceldatum
If IsDate(varWert) Then
varWert = CDate(varWert)
End If
Case Else
End Select
Cells(lngRow, intColumn) = varWert
End If
Next
lngRow = lngRow + 1
Next
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Function fncCheck(ByVal x As Integer, Optional varWerte) As Boolean
Dim intJ As Integer
fncCheck = False
If x