Photgraphy lister

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
I've borrowed a couple of methods to list a directory of images and return them to a sheet

Before I paste the code(s) does anyone have a foolproof method that will work from 2007 that they use (the stuff i got isn't as reliable as I hoped)

I want
to navigate to a directory from code
List the folder contents (not interested in sub directories)
Return image file information
>File Name
>Created
>Modified
>File Size
>File Comments
>maybe some camera information and Exif data

VBA Express : Excel - List File Attributes of Directory and Subdirectores
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,514
I wrote the following code to import jpg data from a selected folder. As coded, the macro retains any existing data and simply appends the new data to the workbook, then the data are re-sorted by EXIF date & time. A progress report is displayed on the status bar. The EXIF data I wanted (just the dates & times, really) are obtained using the ExifReader class module from http://prdownloads.sourceforge.net/exifclass/exifreader.zip?download. I wasn't concerned with the file sizes, dates & times, but those are easily obtained.
Code:
Option Explicit
Public oFolder As Object 'the folder object
Public SBar As Boolean ' Status bar state
Public i As Long, j As Long, LRow As Long

Private Sub MacroEntry()
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlManual ' Excel only
End Sub

Private Sub MacroExit()
Application.Calculation = xlAutomatic ' Excel only
Application.StatusBar = False
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub

Sub AddPics()
Call MacroEntry
Dim StrPics As String, StrFldr As String, StrFl As String, StrDtTm As String, StrTmp As String
' Browse for the starting folder
StrFldr = GetFolder & "\"
If StrFldr = "\" Then Exit Sub
StrPics = ","
With ActiveSheet
  .Unprotect
  LRow = .Range("A" & .Rows.Count).End(xlUp).Row
  For i = 2 To LRow
    StrPics = StrPics & .Range("A" & i).Value & ","
  Next
  ' Initialize the counters
  i = 0: j = 0
  'Get the file list
  StrFl = Dir(StrFldr & "*.jpg")
  ' Process the files in the folder
  While StrFl <> ""
    ' Update the status bar is just to let us know where we are
    Application.StatusBar = StrFl
    ' Update the main file counter
    j = j + 1
    'Test whether this file should be processed
    If InStr(StrPics, "," & Split(StrFl, ".")(0) & ",") = 0 Then
      LRow = LRow + 1: i = i + 1: StrTmp = "1900:0:0 0:0:0": StrDtTm = ""
      If i Mod 20 = 0 Then DoEvents
      .Range("A" & LRow).Value = Split(StrFl, ".")(0)
      'Get the EXIF "Date Taken", if present
      Dim EXIF As New ExifReader
      Call EXIF.Load(StrFldr & StrFl)
      On Error Resume Next
      StrTmp = EXIF.Tag(DateTimeOriginal)
      Set EXIF = Nothing
      StrDtTm = Split(Split(StrTmp, ":")(2), " ")(0) & "/" & Split(StrTmp, ":")(1) _
        & "/" & Split(StrTmp, ":")(0) & " " & Split(StrTmp, " ")(1)
      'Output the "Date Taken", if found
      .Range("B" & LRow).Value = CDate(StrDtTm)
    End If
    StrFl = Dir()
  Wend
  'Update the formatting
  With .Range("A1")
    .Value = "Photo ID"
    .ColumnWidth = 10
  End With
  With .Range("B1")
    .Value = "Date"
    .ColumnWidth = 11
  End With
  With .Range("C1")
    .Value = "Location"
    .ColumnWidth = 25
  End With
  With .Range("D1")
    .Value = "Comments"
    .ColumnWidth = 50
  End With
  With .Range("A1:D1")
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
  End With
  .Range("A1:A" & LRow).HorizontalAlignment = xlRight
  .Range("B2:B" & LRow).NumberFormat = "dd-mmm-yyyy"
  'Sort the data
  .Range("A1:D" & LRow).Sort Key1:="Date", Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
  'Apply filters
  .Range("A1:D" & LRow).AutoFilter
  'Apply windowing
  .Range("C2").Activate
  ActiveWindow.FreezePanes = True
  'Protect the headings & formulae from errant fingers
  With .Range("A1:D" & LRow)
    .Locked = False
    .FormulaHidden = False
  End With
  .Rows("A:A").Locked = True
  .Columns("F:G").Locked = True
  .Columns("J:L").Locked = True
  .Protect
End With
Call MacroExit
MsgBox i & " of " & j & " JPG images found in the folder have been added.", vbOKOnly
End Sub

Function GetFolder() As String
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
for whatever reason, i can only get Photo and Date column to populate (Win10 / Excel 2007) for files that do have a full set of Exif information. Any thoughts
 

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,514
As indicated in my post, that's all you get because that's all I coded for. The range of EXIF data you can retrieve via the ExifReader class module is listed under:
Public Enum EXIF_TAG
In my code, you'll see I've only made a call to:
EXIF.Tag(DateTimeOriginal)
There are over 100 other tags you could retrieve.
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows

ADVERTISEMENT

ah, I'll have to investigate more, didn't know where to start
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
really wanted to get at the properties that windows can extract. i.e. when I add a title/comment to a photo in explorer, I then want to be able to recall that in a directory list. Reading the Metadata that windows can already do by the Exif doesn't seem ideal (but what do I know)
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows

ADVERTISEMENT

This gives me the list to work from
Code:
Sub Test()
    Sheets("Sheet2").Select
    Dim objShell As Object    ' Shell
    Dim objFolder As Object    ' Folder
    Dim objFolderItem As Object    ' FolderItem
    ' Other objects
    Dim strPath As String
    Dim i As Integer
    Dim strTitles(39) As String
    Set objShell = CreateObject("Shell.Application")  'Set objShell = New Shell
    Set objFolder = objShell.Namespace("v:\")
    ' If we can find the folder then ...
    If (Not objFolder Is Nothing) Then
        For i = 0 To 312    '400
            ActiveSheet.Cells(i + 1, 1).Value = i & " - " & objFolder.GetDetailsOf(vbNull, i)
        Next i
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
End Sub
 

admiral100

Well-known Member
Joined
Jan 17, 2015
Messages
873
Hi,

This code work for me . (Win 7 &, Excel 2007)

Link :
https://social.msdn.microsoft.com/F...e-format-file-size-and-file-name?forum=isvvba

And more information:
https://technet.microsoft.com/en-us/library/ee176615.aspx



[FONT=&quot]Public Sub ExtractFilePropeties()[/FONT]
[FONT=&quot] Dim arrHeaders(35)[/FONT]
[FONT=&quot] Dim strPath[/FONT]
[FONT=&quot] strPath = "C:\ImageFolder" ''Specify the Image folder name[/FONT]
[FONT=&quot] Worksheets(1).Activate[/FONT]
[FONT=&quot] Set objShell = CreateObject("Shell.Application")[/FONT]
[FONT=&quot] Set objFolder = objShell.Namespace(strPath)[/FONT]
[FONT=&quot] For i = 0 To 34[/FONT]
[FONT=&quot] Cells(1, i + 1) = objFolder.GetDetailsOf(objFolder.Items, i)[/FONT]
[FONT=&quot] Next[/FONT]

[FONT=&quot] Dim fileIncrementer As Integer[/FONT]
[FONT=&quot] For Each strFileName In objFolder.Items[/FONT]
[FONT=&quot] For i = 0 To 34[/FONT]
[FONT=&quot] Cells(fileIncrementer + 2, i + 1) = objFolder.GetDetailsOf(strFileName, i)[/FONT]
[FONT=&quot] Next[/FONT]
[FONT=&quot] fileIncrementer = fileIncrementer + 1[/FONT]
[FONT=&quot] Next[/FONT]
[FONT=&quot]End Sub[/FONT]
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,524
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
Hi,

This code work for me . (Win 7 &, Excel 2007)

Link :
https://social.msdn.microsoft.com/F...e-format-file-size-and-file-name?forum=isvvba

And more information:
https://technet.microsoft.com/en-us/library/ee176615.aspx



[FONT="]Public Sub ExtractFilePropeties()[/FONT][/COLOR]
[COLOR=#333333][FONT="] Dim arrHeaders(35)[/FONT]

[FONT="] Dim strPath[/FONT][/COLOR]
[COLOR=#333333][FONT="] strPath = "C:\ImageFolder" ''Specify the Image folder name[/FONT]

[FONT="] Worksheets(1).Activate[/FONT][/COLOR]
[COLOR=#333333][FONT="] Set objShell = CreateObject("Shell.Application")[/FONT]

[FONT="] Set objFolder = objShell.Namespace(strPath)[/FONT][/COLOR]
[COLOR=#333333][FONT="] For i = 0 To 34[/FONT]

[FONT="] Cells(1, i + 1) = objFolder.GetDetailsOf(objFolder.Items, i)[/FONT][/COLOR]
[COLOR=#333333][FONT="] Next[/FONT]


[FONT="] Dim fileIncrementer As Integer[/FONT][/COLOR]
[COLOR=#333333][FONT="] For Each strFileName In objFolder.Items[/FONT]

[FONT="] For i = 0 To 34[/FONT][/COLOR]
[COLOR=#333333][FONT="] Cells(fileIncrementer + 2, i + 1) = objFolder.GetDetailsOf(strFileName, i)[/FONT]

[FONT="] Next[/FONT][/COLOR]
[COLOR=#333333][FONT="] fileIncrementer = fileIncrementer + 1[/FONT]

[FONT="] Next[/FONT][/COLOR]
[COLOR=#333333][FONT="]End Sub[/FONT]

found similar, change 34 to 317 and see whats brought back
 

Watch MrExcel Video

Forum statistics

Threads
1,123,290
Messages
5,600,759
Members
414,405
Latest member
Zaurb

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top