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