AW: SharePoint Metadaten per VBA in Excel auslesen
15.05.2020 20:30:27
Firmus
Hallo Martin,
ich hatte ähnliches mit den EXIF-Daten von Fotos.
1. Welche Attribute gibt es (ATTR-Namen als Header in XLS anlegen)
2. Aus jedem Bild die vorhandenen ATTR in eine Zeile pro Bild abspeichern.
Eventuell hilft dir diese Methodik.
Hier der Code, der das leistet:
Er ist im Trial and Error Modus entstanden.
Option Explicit
Sub UTIL210_EXIF_auslesen_v12ok()
' Ordner-Auswahl-Dialog aufrufen (Verzeichnis, das die Fotos enthält.)
'Typ=PNG: iPhone screenshot
' kein Aufnahmedatum
' => SET Änderungsdatum als Aufnahmezeit
' => SET TypeValue = "S"
'Typ=MOV: iPhone Video
' kein Aufnahmedatum
' => SET Änderungsdatum als Aufnahmezeit
' => SET TypeValue = "V"
'Typ=MTS: Lumix Video
' kein Aufnahmedatum
' => SET Änderungsdatum als Aufnahmezeit
' => SET TypeValue = "V"
'Typ=JPG: 1. Kamerahersteller=PANASONIC
' Es ist ein Foto
' => SET TypeValue = "B" (Bild)
' 2. Kamerahersteller=Apple
' Es ist ein Foto
' => SET TypeValue = "B"
' 3. Kameramodell CanoScan 9000F
' Es ist ein eingescanntes Blatt, Aufnahmedatum ist vorhanden
' => SET TypeValue = "C" (Copy)
' 4. Aufnahmedatum=leer und Kamerahersteller leer
' Es ist ein Screenshot (Screenhunter oder per Snippingtool)
' => SET Änderungsdatum als Aufnahmezeit
' => SET TypeValue = "S" (Screenshot)
' Alle verbleibenden, nicht passenden Objekte
' => SET TypeValue = "U" Unbekanntes Objekt
Dim oShell As Object
Dim oFolder As Object
Dim strPath As String
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.BrowseForFolder(0, "Bitte einen Ordner auswählen - Verarbeitung OHNE _
Unterverzeichnisse", 1)
If Not oFolder Is Nothing Then
'MsgBox oFolder.Self.Path & " wird ausgelesen."
strPath = oFolder.Self.Path
End If
'Erstellen einer neuer XLS-Datei zum Befüllen mit den EXIF-Daten.
Dim wkbneu As Variant
Dim wksneu As Variant
Workbooks.Add
ActiveSheet.Name = "IDXv12_" & Format((Now), "YYYYMMDD-hhmmss")
wkbneu = ActiveWorkbook.Name
wksneu = ActiveSheet.Name
Application.ScreenUpdating = True 'False
' Die EXIF-Daten werden aus den einzelnen Bildern ausgelesen und in der XLS ergänzt.
Dim arrSize As Long, arrSizeMax As Long
Dim strFile As String
Dim strFileName As Variant
Dim sTemp As Variant
Dim I As Long
Dim arrHeaders(999)
Dim sTempVal As String
Dim tmpC1 As String
' Mögliche EXIF-Attribut-Header auslesen und in die Spaltenheader (Zeile 1) setzen.
Set oShell = Nothing
Set oFolder = Nothing
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.Namespace(strPath & "\")
arrSizeMax = 0
arrSize = 999
For I = 0 To arrSize
arrHeaders(I) = oFolder.GetDetailsOf(oFolder.Items, I)
Cells(1, I + 1).Value = arrHeaders(I)
If arrHeaders(I) "" Then arrSizeMax = I
Next I
I = I 'debug
' Verzeichnis auslesen und Dateinamen, incl. Suffix in die XLS übernehmen.
Dim offSpalt As Long, maxzeil As Long
Dim xzeil As Long
offSpalt = arrSizeMax + 1
xzeil = 1
Cells(xzeil, offSpalt - 1).Value = "SearchVal"
Cells(xzeil, offSpalt + 0).Value = "strPath"
Cells(xzeil, offSpalt + 1).Value = "strfile"
Cells(xzeil, offSpalt + 2).Value = "strPath + strfile"
Cells(xzeil, offSpalt + 3).Value = "Herkunft" 'manuell eintragen
Cells(xzeil, offSpalt + 4).Value = "TypeValue" 'V = MTS or MOV, B = JPG, U = _
unbekannt
Cells(xzeil, offSpalt + 5).Value = "ErzeugDate" 'Picture Taken für JPG, CHAR, Ä _
nderungsdatum für alle anderen (MTS,MOV,PNG - teileweise auch JPG)
Cells(xzeil, offSpalt + 6).Value = "AufnahmeD-Clean" 'Picture Taken für JPG, DATE, Ä _
nderungsdatum für alle anderen (MTS,MOV,PNG - teileweise auch JPG)
Cells(xzeil, offSpalt + 7).Value = "TimeShift" 'manuell
Cells(xzeil, offSpalt + 8).Value = "AufnahmeD-Korrekt" 'in next Macro: AufnahmeD-Clean _
+/- Timeshift = REALE Aufnahmezeit
Cells(xzeil, offSpalt + 9).Value = "FinalFileName" 'in next Macro: "JJJJ_MM_TT_.... _
_Originalname
xzeil = 2
Set oShell = Nothing
Set oFolder = Nothing
Set oShell = CreateObject("Shell.Application")
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strFile = Dir(strPath & "*.*", vbNormal) 'nur bei JPG ist eine CreateDate _
vorhanden.
Do While strFile ""
Cells(xzeil, offSpalt + 0).Value = strPath 'incl "\"
Cells(xzeil, offSpalt + 1).Value = strFile
Cells(xzeil, offSpalt + 2).Value = strPath & strFile
Cells(xzeil, offSpalt + 4).Value = "" 'Default leer
If (UCase(Right(strFile, 3)) = "MTS") Then Cells(xzeil, offSpalt + 4).Value = "V"
If (UCase(Right(strFile, 3)) = "MOV") Then Cells(xzeil, offSpalt + 4).Value = "V"
If (UCase(Right(strFile, 3)) = "JPG") Then Cells(xzeil, offSpalt + 4).Value = "B"
If (UCase(Right(strFile, 3)) = "PNG") Then Cells(xzeil, offSpalt + 4).Value = "S"
If (Cells(xzeil, offSpalt + 4).Value = "") Then Cells(xzeil, offSpalt + 4).Value = "U"
xzeil = xzeil + 1
strFile = Dir
Loop
xzeil = xzeil 'just for debug
' Attribute gemäß XLS-Namensliste auslesen und in Zellen der XLS setzen.
Dim xAendDat As Variant
Dim xAufnDat As Variant
xzeil = 2
strPath = Cells(xzeil, offSpalt + 0).Value
strFile = Cells(xzeil, offSpalt + 1).Value
strPath = Left(strPath, InStrRev(strPath, "\") - 1)
tmpC1 = Cells(1, 1).Value
Set oShell = Nothing
Set oFolder = Nothing
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.Namespace(strPath & "\")
' xzeil = 2
For Each strFileName In oFolder.Items
Set xAendDat = Nothing
Set xAufnDat = Nothing
For I = 1 To arrSizeMax
sTemp = arrHeaders(I - 1) 'start at zero
If IsNull(sTemp) Then
sTempVal = "no Parameter"
Else
sTempVal = oFolder.GetDetailsOf(strFileName, I - 1)
End If
Cells(xzeil, I).Value = sTempVal 'Wert des Parameters eintragen
Cells(1, 1).Value = xzeil 'statistic counter only
If sTemp = "Änderungsdatum" Then xAendDat = sTempVal
If sTemp = "Aufnahmedatum" Then xAufnDat = sTempVal
Next I
I = I
'setze die Aufnahmezeit, abhängig vom Dateityp (immer AendDat, nur bei JPG AufnDat, falls _
dies vorhanden ist.
Cells(xzeil, offSpalt + 5).Value = xAendDat
If xAufnDat "" Then Cells(xzeil, offSpalt + 5).Value = xAufnDat
xzeil = xzeil + 1
Next strFileName
I = I
Cells(1, 1).Value = tmpC1
End Sub
Lass wissen ob es für Sharepoint passt - Danke.
Gruß,
Firmus