Option Explicit
Public ErrorMsgDesc As Variant
Public ErrorMsgNum As String
' LIST FILES
Sub ListFilesMaster()
Dim fso As Object
Dim Folder1 As Object
Dim Temp As Variant
Dim xPath As String
Dim xWs As Worksheet
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If Len(Range("D_LastPath")) > 0 Then
.InitialFileName = Range("D_LastPath")
Else
.InitialFileName = "C:\"
End If
.Title = "Choose the folder"
Temp = .Show
End With
If Temp = True Then
Range("D_LastPath") = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
If Right(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1), 1) <> "\" Then xPath = xPath & "\"
Set xWs = Application.ActiveSheet
xWs.Range(Columns(1), Columns(3)).ClearContents
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 3).Value = Array("Path", "File", "Path Length")
xWs.Cells(2, 1).Resize(1, 3).Interior.Color = 65535
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xRow = 3
ListFilesSubFolders xWs, xPath, xRow
SortData xWs, 1, xWs.Range("SortRange").Columns.Count, xlDescending
End If 'Temp = True
End Sub 'ListFilesMaster
Sub ListFilesSubFolders(ByRef xWs As Worksheet, xPath As String, xRow As Long)
Dim Folder1 As Object
Dim Folder2 As Object
Dim fso As Object
Dim SubFolder As Object
Dim subfld As String
Dim Temp As Variant
Dim xRowTemp As Long
On Error GoTo ErrorRoutine
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xWs.Cells(xRow, 1) = Folder1.Path
xRowTemp = xRow
ListFiles xWs, Folder1, xRow
If xRow = xRowTemp Then xRow = xRow + 1
'After listing the files in this folder, look to see if there are sub-folders in this folder
'If a subfolder is encountered that the user does not have permission for an error will occur
'The error handling routine will skip the folder
If Folder1.subfolders.Count > 0 Then
For Each SubFolder In Folder1.subfolders
If Len(SubFolder.Path) > 0 Then
subfld = SubFolder.Path
If Right(subfld, 1) <> "\" Then subfld = subfld & "\"
DoEvents
ListFilesSubFolders xWs, subfld, xRow
End If 'Len(SubFolder.Path) > 0
Next SubFolder
SkipSubFolder:
On Error GoTo ErrorRoutine
End If 'Folder1.subfolders.Count > 0
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume SkipSubFolder 'Permission denied
If ErrorMsgNum = 70 Then Resume SkipSubFolder 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module ListFilesSubFolders"
Resume ExitRoutine
End Sub 'ListFilesSubFolders
Sub ListFiles(xWs As Worksheet, ByVal sPath As String, xRow As Long, Optional ByVal sFilter As String)
Dim sFile As String
On Error GoTo ErrorRoutine
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file
sFile = Dir(sPath & sFilter, vbSystem)
'call it until there is no filename returned
Do While sFile <> ""
'store the file name in the array
xWs.Cells(xRow, 1) = sPath
xWs.Cells(xRow, 2) = sFile
xWs.Cells(xRow, 3).Formula = "=LEN(A:A)+LEN(B:B)"
xRow = xRow + 1
'subsequent calls without param return next file
sFile = Dir
Loop
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume ExitRoutine 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module ListFiles"
Resume ExitRoutine
End Sub 'ListFiles
' DELETE FILES
Sub DeleteFilesMaster()
Dim Folder1 As Object
Dim fso As Object
Dim Temp As Variant
Dim xPath As String
On Error GoTo ErrorRoutine
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
Temp = .Show
End With
If Temp = True Then
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
If Right(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1), 1) <> "\" Then xPath = xPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
DeleteFilesSubFolders Folder1
End If 'Temp = True
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module DeleteFile"
Resume ExitRoutine
End Sub 'DeleteFilesMaster
Sub DeleteFilesSubFolders(ByRef prntfld As Object)
Dim Folder2 As Object
Dim fso As Object
Dim sFile As String
Dim SubFolder As Object
Dim subfld As String
Dim Temp As Variant
Dim xRowTemp As Long
On Error GoTo ErrorRoutine
subfld = prntfld.Path
If Right(subfld, 1) <> "\" Then subfld = subfld & "\"
sFile = subfld & "Thumbs.db"
'Check File Exists or Not
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(sFile) Then
'If file exists, It will delete the file
On Error Resume Next
fso.DeleteFile sFile, True
On Error GoTo ErrorRoutine
Else
'If file does not exists, It will do nothing
End If
'After deleting the files in this folder, look to see if there are sub-folders in this folder
For Each SubFolder In prntfld.subfolders
If prntfld.subfolders.Count > 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder2 = fso.getFolder(subfld)
DoEvents
'If a subfolder is encountered that the user does not have permission for an error will occur
If Folder2.subfolders.Count > 0 Then DeleteFilesSubFolders Folder2
SkipSubFolder:
On Error GoTo ErrorRoutine
End If 'prntfld.subfolders.Count > 0
Next SubFolder
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume SkipSubFolder 'Permission denied
If ErrorMsgNum = 70 Then Resume SkipSubFolder 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module DeleteFilesSubFolders"
Resume ExitRoutine
End Sub 'DeleteFilesSubFolders
' RENAME FILES
Sub RenameFilesMaster()
Dim fso As Object
Dim Folder1 As Object
Dim Temp As Variant
Dim xPath As String
Dim xWs As Worksheet
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
Temp = .Show
End With
If Temp = True Then
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
If Right(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1), 1) <> "\" Then xPath = xPath & "\"
Set xWs = Application.ActiveSheet
xWs.Range(Columns(1), Columns(3)).ClearContents
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 3).Value = Array("Path", "File", "Path Length")
xWs.Cells(2, 1).Resize(1, 3).Interior.Color = 65535
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xRow = 3
RenameFilesSubFolders xWs, xPath, xRow
SortData xWs, 1, xWs.Range("SortRange").Columns.Count, xlDescending
End If 'Temp = True
End Sub 'RenameFiles
Sub RenameFilesSubFolders(ByRef xWs As Worksheet, xPath As String, xRow As Long)
Dim Folder1 As Object
Dim Folder2 As Object
Dim fso As Object
Dim SubFolder As Object
Dim subfld As String
Dim Temp As Variant
Dim xRowTemp As Long
On Error GoTo ErrorRoutine
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xWs.Cells(xRow, 1) = Folder1.Path
On Error GoTo ErrorRoutine
xRowTemp = xRow
RenameFiles xPath
If xRow = xRowTemp Then xRow = xRow + 1
'After listing the files in this folder, look to see if there are sub-folders in this folder
'If a subfolder is encountered that the user does not have permission for an error will occur
'The error handling routine will skip the folder
If Folder1.subfolders.Count > 0 Then
For Each SubFolder In Folder1.subfolders
If Len(SubFolder.Path) > 0 Then
subfld = SubFolder.Path
If Right(subfld, 1) <> "\" Then subfld = subfld & "\"
DoEvents
RenameFilesSubFolders xWs, subfld, xRow
End If 'Len(SubFolder.Path) > 0
Next SubFolder
SkipSubFolder:
On Error GoTo ErrorRoutine
End If 'Folder1.subfolders.Count > 0
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume SkipSubFolder 'Permission denied
If ErrorMsgNum = 70 Then Resume SkipSubFolder 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module RenameFilesSubFolders"
Resume ExitRoutine
End Sub 'RenameFilesSubFolders
Sub RenameFiles(ByVal sPath As String, Optional ByVal sFilter As String)
Dim aFileNames() As String
Dim sFileNew As String
Dim sFileOld As String
Dim sFileCheck As String
Dim nCounter As Long
On Error GoTo ErrorRoutine
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file
sFileOld = Dir(sPath & sFilter, vbSystem)
'call it until there is no filename returned
Do While sFileOld <> ""
If Not (IsError(Application.Search(Range("R_OldName"), sFileOld))) Then
' sFileNew = Application.Substitute(sFileOld, OldPart, NewPart, 1) ' Only first occurrence
sFileNew = Application.Substitute(sFileOld, Range("R_OldName"), Range("R_NewName")) ' All occurrences
Name sPath & sFileOld As sPath & sFileNew
End If
'subsequent calls without param returns next file
sFileOld = Dir
Loop
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume ExitRoutine 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module RenameFiles"
Resume ExitRoutine
End Sub 'RenameFiles
' RENAME FOLDERS
Sub RenameFoldersMaster()
Dim fso As Object
Dim Folder1 As Object
Dim Temp As Variant
Dim xPath As String
Dim xWs As Worksheet
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
Temp = .Show
End With
If Temp = True Then
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
If Right(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1), 1) <> "\" Then xPath = xPath & "\"
Set xWs = Application.ActiveSheet
xWs.Range(Columns(1), Columns(3)).ClearContents
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 3).Value = Array("Path", "File", "Path Length")
xWs.Cells(2, 1).Resize(1, 3).Interior.Color = 65535
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xRow = 3
RenameFoldersSubFolders xWs, xPath, xPath, xRow
SortData xWs, 1, xWs.Range("SortRange").Columns.Count, xlDescending
End If 'Temp = True
End Sub 'RenameFoldersMaster
Sub RenameFoldersSubFolders(ByRef xWs As Worksheet, xPath As String, xPathPrev As String, xRow As Long)
Dim Folder1 As Object
Dim Folder2 As Object
Dim sFolderNew As String
Dim fso As Object
Dim SubFolder As Object
Dim subfld As String
Dim Temp As Variant
Dim xRowTemp As Long
On Error GoTo ErrorRoutine
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder1 = fso.getFolder(xPath)
xWs.Cells(xRow, 1) = Folder1.Path
On Error GoTo ErrorRoutine
xRowTemp = xRow
' RenameFolders xPath, Folder1.Name
If xRow = xRowTemp Then xRow = xRow + 1
'After checking to see if this folder requires renaming, look to see if there are sub-folders in this folder
'If a subfolder is encountered that the user does not have permission for an error will occur
'The error handling routine will skip the folder
If Folder1.subfolders.Count > 0 Then
For Each SubFolder In Folder1.subfolders
If Len(SubFolder.Path) > 0 Then
subfld = SubFolder.Path
If Right(subfld, 1) <> "\" Then subfld = subfld & "\"
DoEvents
RenameFoldersSubFolders xWs, subfld, xPath, xRow
End If 'Len(SubFolder.Path) > 0
Next SubFolder
SkipSubFolder:
On Error GoTo ErrorRoutine
End If 'Folder1.subfolders.Count > 0
If Not (IsError(Application.Search(Range("R_OldName"), Folder1.Name))) Then
' sFileNew = Application.Substitute(sFileOld, OldPart, NewPart, 1) ' Only first occurrence
sFolderNew = Application.Substitute(Folder1.Name, Range("R_OldName"), Range("R_NewName")) ' All occurrences
Name xPathPrev & Folder1.Name As xPathPrev & sFolderNew
End If
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume SkipSubFolder 'Permission denied
If ErrorMsgNum = 70 Then Resume SkipSubFolder 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module RenameFoldersSubFolders"
Resume ExitRoutine
End Sub 'RenameFoldersSubFolders
Sub RenameFolders(sPath As String, sFolderOld As String)
Dim sFolderNew As String
On Error GoTo ErrorRoutine
If Not (IsError(Application.Search(Range("R_OldName"), sFolderOld))) Then
' sFileNew = Application.Substitute(sFileOld, OldPart, NewPart, 1) ' Only first occurrence
sFolderNew = Application.Substitute(sFolderOld, Range("R_OldName"), Range("R_NewName")) ' All occurrences
Name sPath & sFolderOld As sPath & sFolderNew
End If
ExitRoutine:
Exit Sub
ErrorRoutine:
ErrorMsgNum = Err.Number
If ErrorMsgNum = 52 Then Resume ExitRoutine 'Permission denied
ErrorMsgDesc = Err.Description
MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module RenameFolders"
Resume ExitRoutine
End Sub 'RenameFolders
' COMMON ROUTINES
Sub SortData(xWs As Worksheet, SortColumn1 As Integer, SortColumn2 As Integer, SortOrder2 As Integer)
With xWs
.Range(.Cells(2, 1), .Cells(2, .Range("SortRange").Columns.Count)).AutoFilter
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 Key:=.Cells(2, SortColumn1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 Key:=.Cells(2, SortColumn2), SortOn:=xlSortOnValues, Order:=SortOrder2, DataOption:=xlSortTextAsNumbers
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With 'xWs
End Sub 'SortData
