Hallo allemaal,
Toelichting:
Ik heb een Excel subroutine gemaakt die gegevens van opgeslagen foto's in een Excelblad plaatst (directory, bestandsnaam, "date taken" evt. "date modified"). Zelf vul ik het Excel-blad aan met plaats van opname, beschrijving, trefwoorden etc.
Subroutine:
Ik gebruik de instructie objFolder.GetDetailsOf(strFileName, 12) om "date take" op te halen.
Heel bijzonder dat de output ogenschijnlijk een TEKST lijkt op te leveren, ik had een datum-format verwacht.
- In Excel omzetten met Datevalue werkt niet.
- Cdate(objFolder.GetDetailsOf(strFileName, 12)) in de subroutine leidt tot een conflict.
Vraag:
Hoe verkrijg ik de datum van een foto (in datumformaat)?
Toelichting:
Ik heb een Excel subroutine gemaakt die gegevens van opgeslagen foto's in een Excelblad plaatst (directory, bestandsnaam, "date taken" evt. "date modified"). Zelf vul ik het Excel-blad aan met plaats van opname, beschrijving, trefwoorden etc.
Subroutine:
Ik gebruik de instructie objFolder.GetDetailsOf(strFileName, 12) om "date take" op te halen.
Heel bijzonder dat de output ogenschijnlijk een TEKST lijkt op te leveren, ik had een datum-format verwacht.
- In Excel omzetten met Datevalue werkt niet.
- Cdate(objFolder.GetDetailsOf(strFileName, 12)) in de subroutine leidt tot een conflict.
Vraag:
Hoe verkrijg ik de datum van een foto (in datumformaat)?
Code:
Sub Scan()
'
' Scan Macro
'Zet Exif-informatie van fotobestanden in een lijst
'Bron: Helpmij.nl forum, 20191016
Dim strDirectorynaam(200) As Variant
Dim hulp, jaar, maand, dag
Dim newsheet
Dim startPath
Dim fs As Object 'fs = filesytem
'Specific declaration of pickung up EXIF-info
Dim fPath As Variant
Dim objShell As Object
Dim objFolder As Object
Dim strFileName As Object
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set fs = CreateObject("Scripting.FileSystemObject")
'On Error GoTo Errorhandler
'1. Maak nieuwe lege Aanvullende Fotolijst
Set newsheet = ThisWorkbook.Sheets.Add(After:=Sheets(Worksheets.Count))
MsgBox Str(Worksheets.Count)
newsheet.Name = "Aanvulling" + Str(Worksheets.Count) 'Probeer hiermee onafhankelijk van taal te worden (Blad2 of sheet2)"
'Vul de titelrij
Cells(1, 1) = "Volume"
Cells(1, 2) = "Directory"
Cells(1, 3) = "Bestandsnaam"
Cells(1, 4) = "Datum"
Cells(1, 5) = "Categorie"
Cells(1, 6) = "Land"
Cells(1, 7) = "Plaats"
Cells(1, 8) = "Beschrijving"
Cells(1, 9) = "Wijzigingsdatum"
'Zet de header vast
Range("B2").Select
ActiveWindow.FreezePanes = True
Selection.AutoFilter
'===============================================================================================
'2. Vraag eerst alle directorys op en plaats de gegevens in een matrix
rij = 0
'Op het tabblad "Scan driectory" zet je in cell "B5" de naam van de map waarin subdirectories met foto's staan
startPath = Sheets("Scan directory").Range("B5") ' Set the path.
'MsgBox startPath, vbYesNo
mydir = Dir(startPath, vbDirectory) ' Retrieve the first entry.
Do While mydir <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If mydir <> "." And mydir <> ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(startPath & mydir) And vbDirectory) = vbDirectory Then
rij = rij + 1
strDirectorynaam(rij) = mydir
'MsgBox mydir 'Werkt goed
End If
End If
mydir = Dir ' Get next entry.
Loop
'===============================================================================================
'3. Paats de EXIF-info in een werkblad
Set objShell = CreateObject("Shell.Application")
'Set objFolder = objShell.Namespace(startPath & trDirecotry)
n = 1
row = 2
'Doorloop alle alle directories
Do While strDirectorynaam(n) <> ""
fPath = CVar(startPath & strDirectorynaam(n))
'MsgBox fPath
Set objFolder = objShell.Namespace(fPath)
'Set objFolder = objShell.Namespace("D:\Nieuw\_Inbewerking\2019_AnnaPaulowna")
'MsgBox objFolder
'Loop through all Items (files) in folders
For Each strFileName In objFolder.Items
'MsgBox strFileName 'Gaat goed
For i = 0 To 39
Debug.Print objFolder.GetDetailsOf(strFileName, i) & "<br />" & vbCrLf
Next
'Look only for image files
If InStr(objFolder.GetDetailsOf(strFileName, 2), "image") Then
Cells(row, 2) = strDirectorynaam(n) 'Directorynaam
Cells(row, 3) = objFolder.GetDetailsOf(strFileName, 0) 'Bestandsnaam
'"Date taken" blijkt niet altijd beschikbaar,
If CStr(objFolder.GetDetailsOf(strFileName, 12)) <> "" Then
Cells(row, 4) = (objFolder.GetDetailsOf(strFileName, 12)) 'Date taken
Else
'MsgBox row & "lege date taken"
Cells(row, 4) = CDate(objFolder.GetDetailsOf(strFileName, 3)) 'Date modified
End If
' Cells(1, 10) = "Date Modified"
' Cells(1, 11) = "Date Created"
' Cells(1, 12) = "Date Taken"
' Cells(row, 10) = CDate(objFolder.GetDetailsOf(strFileName, 3)) 'Date modified
' Cells(row, 11) = CDate(objFolder.GetDetailsOf(strFileName, 4)) 'Date created
' Cells(row, 12) = objFolder.GetDetailsOf(strFileName, 12) 'Date taken
row = row + 1
End If
Next 'Next file
n = n + 1 'Ga naar de volgende directory
Loop 'Next directory
'Maak de lijst netjes op
Range("A1:J1").Font.Bold = True
Range("A1:J1").HorizontalAlignment = xlRight
Columns("D:D").NumberFormat = "dd-mm-yyyy hh:mm"
'Sluit het bestand af
Columns("A:J").EntireColumn.AutoFit
End Sub
