VBA to rename picture files based on date taken

[roc_on_the_rocks]

Hello guys,
I'm taking the Christmas break to organize my 'digital life' and the biggest chunk of it are photos (and videos) files, ten thousands of them, in hundreds of folders.

The problem is that most of these photo files are named like 'IMG_xxxx.jpg'.

I'm looking for a macro that would scan the files in a given folder and would:
1) Rename the photo files with a naming format like this: YYYYMMDD_HHMMSS, based on 'Date Taken' from the EXIF metadata. Skip file if 'Date Taken' is unavailable (like in video files).
2) Create and save an Excel file (it can be csv) in that given folder, with columns listing the original file names and new names.

Of course #1 is more important, #2 is a 'nice to have'.

Do anyone have something like this?

Thanks a million guys! Great to be back here.

 

[roc_on_the_rocks]

That is great, molte grazie rollis13!

This is good timing, I was planning to fiddle with it tonight, to try adding the Shell.Application BrowseForFolder to it (replacing the hardcoded folder path). I'm all ears to any suggestions you may have.

 

[roc_on_the_rocks]

rollis13, your code is working great! If you're still available for further finishing touches, I appreciate it, otherwise, BIG THANKS for your great help!

Three new thoughts:

1) I added a piece of code to allow the user to select the directory on the fly (versus having it hardcoded). It may not be pretty coding but it's working, feel free to suggest improvements.

2) I made an attempt to split the log file in column A in columns A and B. It didn't work, so I'm 'commenting' those lines of code.

3) As further polishing, it would be nice if the code would ask the user if an additional name should be appended to the new file names. Suppose all or the majority of the pictures in the selected folder are wedding related, the user would type 'wedding' and the picture files would be named as: YYYYMMDD_HHMMSS_wedding

Option Explicit
Sub RetrieveExifData()
    'requires reference to: Microsoft Scripting Runtime

    Dim fso    As Scripting.FileSystemObject
    Dim fldr   As Scripting.Folder
    Dim fl     As Scripting.file
    Dim pth    As String
    Dim fDate  As String
    Dim Line   As String
    Dim objShell As Object, objFolder As Object     'added by ROC


'\\\\\\\\\\\\\\\\\\\ added by ROC \\\\\\\\\\\\\\\\\\\
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        pth = objFolder.self.Path & "\"
    Else
        Exit Sub
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
'////////////////////////////////////////////////////


    'pth = "C:\Users\bi878\Pictures\Test2\"                       '<= change as suited, path MUST have ending backslash "\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(pth)
    'create log file in same folder
    Open pth & "\_LogJpgRenaming.csv" For Output As #1
    Print #1, "Old Name;New Name"
    
'\\\\\\\\\\\\\\\ THIS IS NOT WORKING \\\\\\\\\\\\\\\
'    Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
'        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
'        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
'        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'    Columns("A:B").EntireColumn.AutoFit
'////////////////////////////////////////////////////
    
    On Error GoTo ExifError
    'cycle all files in folder
    For Each fl In fldr.Files
        'process only jpg files
        If UCase(Right(fl.Name, 3)) = "JPG" Then
            With GPSExifReader.OpenFile(fl.Path)
                'retrieve exif date & time and format YYYYMMDD_HHMMSS
                fDate = Replace(Left(Replace(.DateTimeOriginal, ":", ""), 15), " ", "_")
                If fDate <> "" Then
                    'update log file
                    Line = fl.Name & ";" & fDate & ".jpg" '& ";"
                    Print #1, Line
                    Name fl As pth & fDate & ".jpg"
                Else
                    MsgBox "File: " & fl.Name & vbCrLf & "has no EXIF information." 'exif exists but is empty
                End If
            End With
        End If
NextFile:
    Next
    Set fso = Nothing
    Close #1
    MsgBox "Done"
    Exit Sub
ExifError:
    MsgBox "An error has occurred with file: " & fl.Name & vbCrLf & vbCrLf & Err.Description 'no EXIF data (or other error)
    Err.Clear
    Resume NextFile
   
End Sub

 

[rollis13]

1) it's a standard snippet for retrieving folders, would have liked a default folder to start from instead of the root folder, lets say "C:\Users\bi878\Pictures".
2) no, your code isn't necessary, the problem probably is the field separator, change ";" to "," (comma) because Excel normally opens .csv files and divides in columns if it recognizes the separator. I added a variable to make it easier.
3) added a request for a suffix.

Option Explicit

Sub RetrieveExifData()
    'requires reference to: Microsoft Scripting Runtime

    Dim fso    As Scripting.FileSystemObject
    Dim fldr   As Scripting.Folder
    Dim fl     As Scripting.file
    Dim pth    As String
    Dim fDate  As String
    Dim Line   As String
    Dim objShell As Object, objFolder As Object   'added by ROC
    Dim fieldSep As String, answr As String, suffix As String '<= added

    '\\\\\\\\\\\\\\\\\\\ added by ROC \\\\\\\\\\\\\\\\\\\
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Please select the folder to process", 0, 0)
    If Not objFolder Is Nothing Then
        pth = objFolder.Self.Path & "\"
    Else
        Exit Sub
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    '////////////////////////////////////////////////////
 
    'pth = "C:\Users\bi878\Pictures\Test2\"                       '<= change as suited, path MUST have ending backslash "\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(pth)
    fieldSep = ";"                                '<= added - change field separator as suited
    'create log file in same folder
    Open pth & "\_LogJpgRenaming.csv" For Output As #1
    Print #1, "Old Name" & fieldSep & "New Name"  '<= updated
 
    '\\\\\\\\\\\\\\\ THIS IS NOT WORKING \\\\\\\\\\\\\\\
    '    Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    '        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    '        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
    '        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    '    Columns("A:B").EntireColumn.AutoFit
    '////////////////////////////////////////////////////
 
    '---------------------------------------------------
    'add a name suffix
    answr = MsgBox("Do you need a tail suffix ?", vbQuestion + vbYesNo + vbDefaultButton1)
    If answr = vbYes Then
        suffix = InputBox("Please indicate the suffix")
        suffix = "_" & suffix
    End If
    '---------------------------------------------------
    On Error GoTo ExifError
    'cycle all files in folder
    For Each fl In fldr.Files
        'process only jpg files
        If UCase(Right(fl.Name, 3)) = "JPG" Then
            With GPSExifReader.OpenFile(fl.Path)
                'retrieve exif date & time and format YYYYMMDD_HHMMSS
                fDate = Replace(Left(Replace(.DateTimeOriginal, ":", ""), 15), " ", "_")
                If fDate <> "" Then
                    'update log file
                    Line = fl.Name & fieldSep & fDate & suffix & ".jpg" '<= updated
                    Print #1, Line
                    Name fl As pth & fDate & suffix & ".jpg"
                Else
                    MsgBox "File: " & fl.Name & vbCrLf & "has no EXIF information." 'EXIF exists but is empty
                End If
            End With
        End If
NextFile:
    Next
    Set fso = Nothing
    Close #1
    MsgBox "Done"
    Exit Sub
ExifError:
    MsgBox "An error has occurred with file: " & fl.Name & vbCrLf & vbCrLf & err.Description 'no EXIF data (or other error)
    err.Clear
    Resume NextFile
 
End Sub

 

[roc_on_the_rocks]

rollis13, everything worked perfectly, thanks again. Also thanks for the explanations as it help me to learn.

Merry Christmas!

 

[kiteifitswindy]

Thanks for the prompt reply. I checked the Microsoft Scripting Runtime box (in VBA => Tools => References) and that cleared that error.

There's a new error further down (Compile error: 'Variable not defined'), at this line (with 'GPSExifReader' highlighted):

With GPSExifReader.OpenFile(fl.Path)

roc_on_the_rocks,

It seems from your subsequent posts that you figured out the problem here and fixed it, but I do not see you mention what the problem was. I have exactly the same problem and cannot solve it. If you could post the fix you figured out that would be very much appreciated.

Regards
Michael

 

[roc_on_the_rocks]

roc_on_the_rocks,

It seems from your subsequent posts that you figured out the problem here and fixed it, but I do not see you mention what the problem was. I have exactly the same problem and cannot solve it. If you could post the fix you figured out that would be very much appreciated.

Regards
Michael

Michael,
I honestly could not figure out what's wrong with it. The user rollis13 messaged me a link to his version of the file, and his file worked! Baffled, I compared both Excel files, compare the VBA scripts (including the three Class Modules) and they're identical!

 

[kiteifitswindy]

Michael,
I honestly could not figure out what's wrong with it. The user rollis13 messaged me a link to his version of the file, and his file worked! Baffled, I compared both Excel files, compare the VBA scripts (including the three Class Modules) and they're identical!

Roc on the Rocks
I am baffled too, as I can get other code to call class modules just fine, but that one just won't work! Any chance you could send me your file to check out. Perhaps you could email it to mikeworkaddress "at" hotmail.com? I would very much appreciate it if you would be willing to do that!
Regards
Michael

 

[roc_on_the_rocks]

Roc on the Rocks
I am baffled too, as I can get other code to call class modules just fine, but that one just won't work! Any chance you could send me your file to check out. Perhaps you could email it to mikeworkaddress "at" hotmail.com? I would very much appreciate it if you would be willing to do that!
Regards
Michael

Michael, I just emailed you the file, please confirm receiving it.

I still wish someone smarter than me could find out why rollis13's Excel file works and just pasting his VBA on a new Excel file doesn't work.

 

[rollis13]

In addition to copying my macro and Wayne Phillips libraries, have you enabled the reference to the 'Microsoft Scripting Runtime' as required ?

 

[kiteifitswindy]

In addition to copying my macro and Wayne Phillips libraries, have you enabled the reference to the 'Microsoft Scripting Runtime' as required ?

Rollis13

Yes, I am aware of how to enabled the reference to the 'Microsoft Scripting Runtime'. I have done it many times on various spreadsheets I have created, so that is certainly not the problem.

I can tell you that when I copied the code from the RetrieveExifData() in the GPSexp module in the download version, and put it into the spreadsheet that ROC super kindly emailed me, it worked i.e. it is not that part of the code from the download version that is the problem. The problem seems to be in the GPSExifReader class module in the download version. I separately checked that by deleting all the code in that class module of the download version, and putting some simple code in that class module to just confirm that the class module was correctly being called, and that the file path variable was being passed to it correctly, which it was.

Also, when it crashes, it crashes on the line "With GPSExifReader.OpenFile(fl.Path)"

So it seems that somehow there is some issue in the GPSExifReader class module. Perhaps some character one of those lines of crazy higgeldy piggeldy "NativeCode" is not copying and pasting correctly from the download version, but that is beyond my skill level!

But for sure I can confirm that I had no problems with the spreadsheet ROC provided, but I, like ROC, could not get the download version to work.

Thanks again for providing this, will be very useful to me!
Regards
Michael