Excel VBA get extended property for Image file

Hi

There are 287 extended property, to get Image info you can use following code:

Option Explicit

Sub GetImageInfo()

Dim i As Integer, SourceFldr

Dim c As Range, rng As Range

Dim sFile As Variant

Dim oWSHShell As Object



Dim fldr As FileDialog

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

Set oWSHShell = CreateObject("WScript.Shell")



With fldr

    .Title = "Select a Source Folder"

    .AllowMultiSelect = False

    .InitialFileName = oWSHShell.SpecialFolders("Desktop")

    If .Show <> -1 Then GoTo NextCode

    SourceFldr = .SelectedItems(1)

NextCode:

End With



Dim oShell: Set oShell = CreateObject("Shell.Application")

Dim oDir:   Set oDir = oShell.Namespace(SourceFldr)



i = 3

Range("A3:K5000").ClearContents



For Each sFile In oDir.Items

    Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)   'File Name

    Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 1)   'File Size

    Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 2)   'File Type

    Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 5)   'Date Created

    Cells(i, 5).Value = oDir.GetDetailsOf(sFile, 12)  'Date Taken

    Cells(i, 6).Value = oDir.GetDetailsOf(sFile, 31)  'Dimensions

    Cells(i, 7).Value = oDir.GetDetailsOf(sFile, 160) 'Bit Depth

    Cells(i, 8).Value = oDir.GetDetailsOf(sFile, 164) 'Height

    Cells(i, 9).Value = oDir.GetDetailsOf(sFile, 162) 'Width

    Cells(i, 10).Value = oDir.GetDetailsOf(sFile, 161)'Horizontal Resolution

    Cells(i, 11).Value = oDir.GetDetailsOf(sFile, 163)'Vertical Resolution

i = i + 1

Next

    Set oDir = Nothing

    Set oShell = Nothing

Cells.Columns.AutoFit

MsgBox "Done"

End Sub

See attachment.

Cheers!!

Vaibhav