使用 VBA 从 JPG 图像中提取 IPTC 数据

Question

我刚刚在 excel 上创建了一个按钮，允许我 select 一个文件夹并显示其中包含的文件的名称。

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

我想找到一种方法从这些 jpg 文件中的每一个中提取 IPTC 数据，以便在我的 excel 文件中显示它们，但是我找不到任何方法来使用 VBA.

Answer 1

这是一些您可以修改的代码。例如，您可能希望限制为仅查看 *.jpg 个文件。

但是，您还需要确定要提取的特定 IPTC 数据的名称。我包含了一些 IPTC 数据名称，但进行了修改以适应。

请注意，截至今天，在我的计算机上，列表中可能有 320 个文件属性。这个数字以及各种属性的位置会不时更改。我已将 fileProps 设置为 500 的 ubound，但将来可能需要增加（以前 35 就足够了）。

文件属性名称存储在文件夹中。
然后我们确定其索引并使用它来访问文件信息中的适当项目。

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

这是我选择的随机“图片”类型文件夹的输出示例，以及我在宏中硬编码的特定文件属性：

使用 VBA 从 JPG 图像中提取 IPTC 数据

extract IPTC data from JPG images with VBA

excel

vba

iptc