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
