Option Explicit
Option Compare Text
Option Base 1
Private cRng As Range 'current cell - increasing with every new record
Sub ScanFilesInSubfolders()
On Error GoTo errHandler
'Select folder to be scanned
Dim root As String: root = BrowseForFolder
If UCase(root) = "FALSE" Then Exit Sub 'if no folder is selected
If Left(root, 2) = "\\" Then MsgBox "Cannot scan network drives yet!", vbOKOnly: Exit Sub
If Right(root, 1) <> "\" Then root = root & "\" 'make sure we have \ at the end
Dim AbsLevel As Long: AbsLevel = UBound(Split(root, "\")) - 1 'directory depth of root in the drive
Dim RL As Long: RL = 0 'relative directory level - root=0
Dim drv As String: drv = Left(root, 1)
' Dim ColHeaders As String: ColHeaders = "Object,Name,Extension,Type,Size,Full path,Parent folder,Relative level,Attributes,Date created,Date Modified,Date accessed"
Dim i As Long, j As Long
' Stop
Dim wb As Workbook
If Not ActiveWorkbook Is Nothing Then
Set wb = ActiveWorkbook
If MsgBox("All files will be listed down from the ActiveCell. Do you want to continue?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Else
Set wb = Workbooks.Add
End If
i = 0
Set cRng = ActiveCell
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Call checkSubfolders42(root, 0)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
wb.Activate
If wb.Path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else wb.Save
exitPoint:
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set wb = Nothing
Set cRng = Nothing
Exit Sub
errHandler:
MsgBox "An error occurred." & vbCrLf & _
"Number: " & Err.Number & vbCrLf & _
"Description: " & Err.Description & vbCrLf & _
"Error line: " & Erl, vbOKOnly
End Sub
Private Sub checkSubfolders42(strDirectory As String, curLevel As Long, Optional SubDepthLimit As Integer = -1, Optional FolderSize As Boolean = False)
If SubDepthLimit > 0 Then _
If curLevel > SubDepthLimit Then Exit Sub
On Error Resume Next
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object
Dim i As Integer, str1 As String, j As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getfolder(strDirectory)
If objFolder.SubFolders.Count > 0 Then
For Each objSubFolder In objFolder.SubFolders
'RECURSION: Routine calls itself to drill down and check the contents before moving to next one
checkSubfolders42 objSubFolder.Path, (curLevel + 1)
Next objSubFolder
End If
For Each objFile In objFolder.Files
cRng.Value = objFile.Path
Set cRng = cRng.Offset(1)
Next objFile
exitPoint:
Set objFSO = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
Private Function BrowseForFolder(Optional OpenAt As Variant = 17) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", &H1, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.Self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error handler if found
'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
