PDA

View Full Version : [SOLVED] Rename Files By Adding Last Modified Date



JOEYSCLEE
10-06-2016, 09:59 AM
Please help me in macro how to rename all the files (such as excel/PDF/jpg format) in folder / subfolder with original filename & last modified date of the related file via VBA Code.
Actually, I could find VBA Code for Filename with Current date in the forum. But, there are no records/forums for renaming all the files in folder / subfolder with the filename & last modified date / creation date.


Current file name : filename1, filename2
New file name : filename1 MM-DD-YY , filename2 MM-DD-YY

YasserKhalil
10-06-2016, 11:27 AM
Try this code

Sub Rename_All_Files_In_Given_Folder()
Dim FileSystem As Object
Dim strFolder As String

'Change Folder Path To Suit
strFolder = ThisWorkbook.Path & "\Test Folder\"

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(strFolder)

MsgBox "Done...", 64
End Sub

Sub DoFolder(Folder)
Dim SubFolder As Object
Dim File As Object
Dim myPath As String
Dim lResult As Date
Dim strDate As String
Dim strFile As String
Dim strExten As String
Dim strDir As String

For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next SubFolder

For Each File In Folder.Files
myPath = File.Path

strDir = Left(myPath, InStrRev(myPath, "\"))
strFile = CreateObject("Scripting.FileSystemObject").GetBaseName(File.Name)
lResult = Split(FileDateTime(myPath), " ")(0)
strDate = Format(lResult, "MM-DD-YYYY")
strExten = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))

If Not InStr(strFile, strDate) > 0 Then
Name myPath As strDir & strFile & " " & strDate & strExten
End If
Next File
End Sub

JOEYSCLEE
10-07-2016, 11:23 AM
Hello, YasserKhalil
Thank you for the quick response!

After changing the path in Module 1. I added the button to run the code and it did not work. Also, I removed the button & tried to run with Alt F8. Nevertheless, The Pop-up box showed the error "run-time error '76' : Path not found". when I pressed debug, DoFolder FileSystem.GetFolder(strFolder) is highlighted.

In this case, would you please help to review it again? Meanwhile, is it possible to have the Pop-up box to select path instead of the change of the code in Module?

Tks & rgds,
Joey

Leith Ross
10-07-2016, 06:43 PM
Hello Joey,

This macro will let you select the folder you want to search using the File Picker Dialog. Call the Run macro to display it and start renaming the files.

When I read your post, I was not sure if you were only going 1 subfolder down from the parent folder or if you were looking to change files in subfolders of subfolders until there are no more subfolders.

This macro will let you select the depth of recursion for the subfolders. A positive number will limit the recursive search of subfolders to no more than the given number. Zero will search only the parent folder. A negative 1 will search the parent folder and all the subfolders of subfolders until there are no more to search.

Each file's name will have the date it was last modified appended to the original name in the format MM-dd-yyy. This applies to either files with or without extensions.

You can change the level for the subfolder search in the macro Run. It is the second argument in the call to the macro RenameAllFiles.


Macro Code to add the date last modified to all files


' Written: October 07, 2016
' Author: Leith Ross
' Summary Renames all files in a folder by adding the last date modified to the file name.
' The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
' -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
' 0 (zero) renames only the files in the parent folder.
' Any positive number will stop recursion at that depth.


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


Dim File As Object
Dim Files As Object
Dim FileExt As String
Dim Folder As Variant
Dim LastDate As Variant
Dim NewName As String
Dim oShell As Object
Dim SubFolder As Object
Dim SubFolders As Variant
Dim x As Long

Set oShell = CreateObject("Shell.Application")

Set Folder = oShell.Namespace(FolderPath)
If Folder Is Nothing Then
MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
Exit Sub
End If

If Folder.Self.Type Like "*zipped*" Then Exit Sub

Set Files = Folder.Items
Files.Filter 64, "*.*"

For Each File In Files
LastDate = File.ModifyDate
x = InStrRev(File.Name, ".")
If x > 0 Then
FileExt = Right(File.Name, Len(File.Name) - x + 1)
NewName = Left(File.Name, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
Else
NewName = File.Name & " " & Format(LastDate, "mm-dd-yy")
End If
Name File.Path As Folder.Self.Path & "\" & NewName
Next File

Set SubFolders = Folder.Items
SubFolders.Filter 32, "*"

If SubFolderDepth <> 0 Then
For Each SubFolder In SubFolders
Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
Next SubFolder
End If

End Sub




Sub Run()

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Call RenameAllFiles(.SelectedItems(1), -1) ' -1 searches all subfolders. 0 (zero) only the parent folder, and >= 1 sets the maximum number of subfolders to search.
End With


End Sub

YasserKhalil
10-07-2016, 06:48 PM
make sure there is \ at the end of path ..
What is your office version?

YasserKhalil
10-07-2016, 06:59 PM
Great Mr. Leith Ross
That's wonderful and great .. Thanks for sharing it
The code affects the extension of files

JOEYSCLEE
10-07-2016, 07:44 PM
Hello, Leith
Thank you for the reply!!

I just ran the code & the path can be selected now. But, the file type of all files were changed to unknown file type in the folder. Also, when I opened those files, the "Open with" was Pop-up for each file.

Tks & rgds,
Joey

JOEYSCLEE
10-07-2016, 08:04 PM
Hi, Yasserkhalil
I placed the Excel file with your advised Code in the testing folder - C:\Users\123\Pictures\Testing.
Then, I changed the folder name as per your advice.....strFolder = ThisWorkbook.Path & "\Testing\" and ran the Code. Nevertheless, it showed run time error '76'. Enclosed the captures for your reviewing.

Fyi, I'm using Office 2010 in the office and I use it at home as well.



1729317294

YasserKhalil
10-07-2016, 09:10 PM
Put the excel file that has the macro outside the folder and you can use the full path instead

strFolder="C:\Users\123\Pictures\Testing\"

JOEYSCLEE
10-08-2016, 07:52 AM
Thanks YasserKhalil for reviewing...It works perfectly :clap:!!

YasserKhalil
10-08-2016, 09:17 AM
You're welcome. Glad I can offer some help for you

Waiting for Mr. Leith Ross to fix the extension as his code is the best

JOEYSCLEE
10-08-2016, 11:37 AM
Thanks again!! YasserKhalil......Your Code help me to fix the daily issue.

Regarding Leith's Code, I'm looking forward seeing his reply too. It will be great to help my colleague who does not know the Macro much.

Leith Ross
10-08-2016, 11:47 AM
Hello Joey,

Bollocks, I keep forgetting the the Shell object has a option to "Hide extensions of known file types" which is the system default setting. I have that disabled on machine. I have made a few changes to the code and tested it with file extensions and without file extensions options. It works now.

Here is the updated code...



' Written: October 07, 2016
' Updated: October 08, 2016
' Author: Leith Ross
' Summary Renames all files in a folder by adding the last date modified to the file name.
' The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
' -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
' Zero renames only the files in the parent folder.
' Any positive number will stop recursion at that depth.


Global Const SFVVO_SHOWEXTENSIONS As Long = 2


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


Dim File As Object
Dim FileExt As String
Dim FileName As String
Dim Files As Object
Dim Folder As Variant
Dim LastDate As Variant
Dim NewName As String
Dim oShell As Object
Dim SubFolder As Object
Dim SubFolders As Variant
Dim x As Long



Set oShell = CreateObject("Shell.Application")

Set Folder = oShell.Namespace(FolderPath)
If Folder Is Nothing Then
MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
Exit Sub
End If

If Folder.Self.Type Like "*zipped*" Then Exit Sub

Set Files = Folder.Items
Files.Filter 64, "*.*"

For Each File In Files
LastDate = File.ModifyDate

FileName = IIf(Not oShell.GetSetting(SFVVO_SHOWEXTENSIONS), Dir(File.Name), File.Name)

x = InStrRev(FileName, ".")
If x > 0 Then
FileExt = Right(FileName, Len(FileName) - x + 1)
NewName = Left(FileName, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
Else
NewName = FileName & " " & Format(LastDate, "mm-dd-yy")
End If

Name File.Path As Folder.Self.Path & "\" & NewName
Next File

Set SubFolders = Folder.Items
SubFolders.Filter 32, "*"

If SubFolderDepth <> 0 Then
For Each SubFolder In SubFolders
Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
Next SubFolder
End If

End Sub




Sub Run()

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Call RenameAllFiles(.SelectedItems(1), -1)
End With


End Sub

YasserKhalil
10-08-2016, 12:33 PM
Thanks a lot Mr. Leith Ross
I tested the last updated code I got error : File Already Exists at this line

Name File.Path As Folder.Self.Path & "\" & NewName
There is no file with the name of date ..
In fact the previous code was working well except the point of extension...
Is it possible to keep the extension then restore it again?

Leith Ross
10-08-2016, 03:39 PM
Hello Yasser and Joey,

I made a mistake in setting the variable FileName. That is now fixed. I added a check to test if the file already has a date added. You don't want to add another date after an existing date, right?

Here is the amended code.



' Written: October 07, 2016
' Author: Leith Ross
' Summary Renames all files in a folder by adding the last date modified to the file name.
' The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
' -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
' Zero renames only the files in the parent folder.
' Any positive number will stop recursion at that depth.


Global Const SFVVO_SHOWEXTENSIONS As Long = 2


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


Dim File As Object
Dim FileExt As String
Dim FileName As String
Dim Files As Object
Dim Folder As Variant
Dim LastDate As Variant
Dim NewName As String
Dim oShell As Object
Dim SubFolder As Object
Dim SubFolders As Variant
Dim x As Long



Set oShell = CreateObject("Shell.Application")

Set Folder = oShell.Namespace(FolderPath)
If Folder Is Nothing Then
MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
Exit Sub
End If

If Folder.Self.Type Like "*zipped*" Then Exit Sub

Set Files = Folder.Items
Files.Filter 64, "*.*"

For Each File In Files
LastDate = File.ModifyDate

' Get the file name with the extension.
FileName = IIf(Not oShell.GetSetting(SFVVO_SHOWEXTENSIONS), Dir(File.Path), File.Name)

' Don't change the file name if a date has been added.
If Not (FileName Like "* ##-##-##.*" Or File Like "* ##-##-##") Then
x = InStrRev(FileName, ".")

If x > 0 Then
FileExt = Right(FileName, Len(FileName) - x + 1)
NewName = Left(FileName, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
Else
NewName = FileName & " " & Format(LastDate, "mm-dd-yy")
End If

Name File.Path As Folder.Self.Path & "\" & NewName
End If
Next File

Set SubFolders = Folder.Items
SubFolders.Filter 32, "*"

If SubFolderDepth <> 0 Then
For Each SubFolder In SubFolders
Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
Next SubFolder
End If

End Sub




Sub Run()

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Call RenameAllFiles(.SelectedItems(1), -1)
End With


End Sub

JOEYSCLEE
10-08-2016, 08:54 PM
Hello, Leith
The revised Code works Great. Thank you for fixing it!

Again, I really appreiate Yasser & Leith for your help for saving the time in my dailly works:bow:

YasserKhalil
10-08-2016, 08:59 PM
Now it is perfect and wonderful
Thank you very much for your time and effort
In fact I am fond of your solutions. They are distinguished like you
Best Regards

Leith Ross
10-08-2016, 10:20 PM
Hello Joey and Yasser,

Sorry it took me 3 tries to get it right. Thanks for your patience and kind words. If there is anything you want me to explain, just ask.

gowthamtnr
02-13-2018, 01:50 AM
Hi Leith,

Thanks for the code, it helped me as well.

Regards,
Gowtham

snb
02-13-2018, 03:22 AM
This code should be sufficient:


Sub M_snb()
With Application.FileDialog(4)
If .Show Then
sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "*.*"" /b/a-d/s").stdout.readall, vbCrLf)

For j = 0 To UBound(sn) - 1
Name sn(j) As Left(sn(j), Len(sn(j)) - 6) & Replace(Right(sn(j), 6), ".", Format(FileDateTime(sn(j)), "_yyyymmddhhmmss."))
Next
End If
End With
End Sub