[SOLVED] extract IPTC data from JPG images with VBA

extract IPTC data from JPG images with VBA

I've just created a button on excel that allows me to select a folder and display the name of the files it contains.

Sub extract_IPTC_From_Folder()
On Error GoTo err
Dim fileExplorer As FileDialog
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)

fileExplorer.AllowMultiSelect = False

i = 4
With fileExplorer
    If .Show = -1 Then
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        For Each oFile In oFSO.GetFolder(.SelectedItems.Item(1)).Files
            MsgBox oFile.Name
        Next oFile
    Else
        MsgBox "avorted"
        [folderPath] = ""
    End If
End With
err:
Exit Sub
End Sub

I would like to find a way to extract the IPTC data from each of these jpg files to display them in my excel file but I can't find any way to do that with VBA.

Solution

Here is some code you can modify to do that. For example, you might want to restrict to looking only at *.jpg files.

You will also need to determine the names of the specific IPTC data you wish to extract, however. I included some IPTC data names, but modify to suit.

Note that as of today, on my computer, there are 320 file properties possible in the list. This number, as well as the location of various properties, changes from time to time. I have set fileProps to a ubound of 500, but that might need to be increased in the future (it used to be that 35 was sufficient).

The File Property names are stored in the Folder.
We then determine its Index and use that to access the appropriate item in the File information.

Option Explicit
'Reference Microsoft Shell Controls and Automation
'Reference Microsoft Scripting Runtime
Sub getProps()
    Dim PATH_FOLDER As Variant 'as variant, not as string
    Dim objShell As Shell
    Dim objFolder As Folder3
    Dim dProps As Dictionary
    Dim fileProps(500) As Variant
    Dim fi As Object
    Dim I As Long, J As Long, V As Variant
    Dim dFileProps As Dictionary
    Dim filePropIDX() As Long
    Dim wbRes As Workbook, wsRes As Worksheet, rRes As Range, vRes As Variant
    
'determine where results will go
Set wbRes = ActiveWorkbook
Set wsRes = wbRes.Worksheets("FileList") 'change to suit
    Set rRes = wsRes.Cells(1, 1)

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub
    PATH_FOLDER = .SelectedItems(1)
End With

    Set objShell = New Shell
    Set objFolder = objShell.Namespace(PATH_FOLDER)
    
'Get desired extended property index
    With objFolder
        For I = 0 To UBound(fileProps)
            fileProps(I) = .GetDetailsOf(.Items, I)
        Next I
    End With

'desired properties
V = Array("Name", "Date modified", "Authors", "Camera Maker", "Camera Model", "Dimensions", "F-Stop", "Exposure Time")
ReDim filePropIDX(0 To UBound(V))

With Application.WorksheetFunction
    For I = 0 To UBound(V)
        filePropIDX(I) = .Match(V(I), fileProps, 0) - 1
    Next I
End With
    
Set dFileProps = New Dictionary

For Each fi In objFolder.Items
    If fi.Name Like "*.*" Then
        ReDim V(0 To UBound(filePropIDX))
            For I = 0 To UBound(V)
                V(I) = objFolder.GetDetailsOf(fi, filePropIDX(I))
            Next I
            dFileProps.Add key:=fi.Path, Item:=V
    End If
Next fi

'Create results array and write to worksheet
ReDim vRes(0 To dFileProps.Count, 1 To UBound(filePropIDX) + 1)

'Headers:
For J = 0 To UBound(filePropIDX)
    vRes(0, J + 1) = fileProps(filePropIDX(J))
Next J

'data
I = 0
For Each V In dFileProps.Keys
    I = I + 1
    For J = 0 To UBound(dFileProps(V))
        vRes(I, J + 1) = dFileProps(V)(J)
    Next J
Next V
    
'write to the worksheet
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Here is an example of output from a random "pictures" type folder I selected, along with the particular file properties I hard coded in the macro: