For some reason this code is generating a runtime error 5 invalid procedure call or argument. When I click debug it takes me to i = Application.WorksheetFunction.Match(UCase(p.Name), aryFoldersToExclude, 0) in isFolderExcluded sub function. The full code is below:
VBA Code:
Option Explicit
Const colPath As Long = 1
Const colParent As Long = 2
Const colName As Long = 3
Const colFileFolder As Long = 4
Const colCreated As Long = 5
Const colModified As Long = 6
Const colSize As Long = 7
Const colType As Long = 8
Dim aryPathsToInclude() As String, aryFoldersToExclude() As String, aryFilenamesToExclude() As String, arySpecificFilesToExclude() As String
Dim oFSO As Object
Const incFilesFolders As Long = 100
Dim aryFilesFolders() As Object
Dim cntFilesFolders As Long
Sub Main()
Dim i As Long
If Not InitOk Then
Call MsgBox("No top level path specified", vbCritical, "Look for Files & Folders")
Exit Sub
End If
Application.ScreenUpdating = False
ReDim aryFilesFolders(1 To incFilesFolders)
For i = LBound(aryPathsToInclude) To UBound(aryPathsToInclude)
Call getFiles(oFSO.GetFolder(aryPathsToInclude(i)))
Next
ReDim Preserve aryFilesFolders(1 To cntFilesFolders)
listData
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Private Function InitOk() As Boolean
Dim i As Long, n As Long
Dim rPaths As Range, rExcludes As Range, rFiles As Range, rSpecificFiles As Range
Erase aryPathsToInclude
Erase aryFoldersToExclude
Erase aryFilenamesToExclude
Erase arySpecificFilesToExclude
InitOk = True
'build paths list
Set rPaths = Worksheets("FoldersToDo").Cells(1, 1).CurrentRegion
If Len(rPaths.Cells(1, 1).Value) > 0 Then ' there are paths
InitOk = True
ReDim aryPathsToInclude(1 To rPaths.Cells.Count)
For i = 1 To rPaths.Cells.Count
aryPathsToInclude(i) = Trim(rPaths.Cells(i))
Next i
Else
InitOk = False
Exit Function
End If
'build excluded folders list
Set rExcludes = Worksheets("FoldersToDo").Cells(1, 3).CurrentRegion
If Len(rExcludes.Cells(1, 1).Value) > 0 Then ' there are excluded folders
ReDim aryFoldersToExclude(1 To rExcludes.Cells.Count)
For i = 1 To rExcludes.Cells.Count
aryFoldersToExclude(i) = Trim(UCase(rExcludes.Cells(i)))
Next i
End If
'build excluded files list
Set rFiles = Worksheets("FoldersToDo").Cells(1, 5).CurrentRegion
If Len(rFiles.Cells(1, 1).Value) > 0 Then ' there are excluded folders
ReDim aryFilenamesToExclude(1 To rFiles.Cells.Count)
For i = 1 To rFiles.Cells.Count
aryFilenamesToExclude(i) = Trim(UCase(rFiles.Cells(i)))
Next i
End If
'build excluded specific files list
Set rSpecificFiles = Worksheets("FoldersToDo").Cells(1, 7).CurrentRegion
If Len(rSpecificFiles.Cells(1, 1).Value) > 0 Then ' there are excluded folders
ReDim arySpecificFilesToExclude(1 To rSpecificFiles.Cells.Count)
For i = 1 To rSpecificFiles.Cells.Count
arySpecificFilesToExclude(i) = UCase(rSpecificFiles.Cells(i))
Next i
End If
'create File System Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
cntFilesFolders = 0
End Function
Sub getFiles(oPath As Object)
Dim oFolder As Object, oSubFolder As Object, oFile As Object
If isFolderExcluded(oPath) Then Exit Sub ' stops recursion
Call addFileFolder(oPath)
For Each oFile In oPath.Files
If Not isFileExcluded(oFile) Then
If Not isSpecificFileExcluded(oFile) Then Call addFileFolder(oFile)
Else
If Not isSpecificFileExcluded(oFile) Then Call addFileFolder(oFile)
End If
Next
For Each oSubFolder In oPath.SubFolders
Call getFiles(oSubFolder)
Next
End Sub
' IFolder object
' Attributes, DateCreated, DateLastAccessed, DateLastModified, Drive,
' Files, IsRootFolder, Name, ParentFolder (IFolder), Path,
' ShortName, ShortPath, Size, SubFolders, Type
' iFile object
' Attributes, DateCreated, DateLastAccessed, DateLastModified, Drive (IDrive),
' Name, ParentFolder (IFolder), Path, ShortName, ShortPath, Size, Type
' Attributes
Private Sub listData()
Dim rowOut As Long, i As Long, j As Long
Dim wsOut As Worksheet
rowOut = 1
Set wsOut = Worksheets("Files")
wsOut.Cells(1, 1).CurrentRegion.Clear
wsOut.Cells(rowOut, colPath).Value = "FILE/FOLDER PATH"
wsOut.Cells(rowOut, colParent).Value = "PARENT FOLDER"
wsOut.Cells(rowOut, colName).Value = "FILE/FOLDER NAME"
wsOut.Cells(rowOut, colFileFolder).Value = "FILE or FOLDER"
wsOut.Cells(rowOut, colCreated).Value = "DATE CREATED"
wsOut.Cells(rowOut, colModified).Value = "DATE MODIFIED"
wsOut.Cells(rowOut, colSize).Value = "SIZE"
rowOut = rowOut + 1
For i = LBound(aryFilesFolders) To UBound(aryFilesFolders)
With aryFilesFolders(i)
wsOut.Cells(rowOut, colPath).Value = .Path
wsOut.Cells(rowOut, colParent).Value = oFSO.GetParentFolderName(.Path) ' <<<<<<<<<<
wsOut.Cells(rowOut, colName).Value = .Name
wsOut.Cells(rowOut, colFileFolder).Value = TypeName(aryFilesFolders(i))
If TypeName(aryFilesFolders(i)) = "Folder" Then
wsOut.Cells(rowOut, colFileFolder).Value = "Folder"
For j = LBound(aryPathsToInclude) To UBound(aryPathsToInclude)
If UCase(.Path) = aryPathsToInclude(j) Then
wsOut.Cells(rowOut, colFileFolder).Value = "Parent Folder"
Exit For
End If
Next j
End If
wsOut.Cells(rowOut, colCreated).Value = .DateCreated
wsOut.Cells(rowOut, colModified).Value = .DateLastModified
wsOut.Cells(rowOut, colSize).Value = .Size
End With
rowOut = rowOut + 1
Next i
'remove duplicates
wsOut.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'final format
wsOut.Columns(colName).HorizontalAlignment = xlLeft
wsOut.Columns(colCreated).NumberFormat = "m/dd/yyyy"
wsOut.Columns(colModified).NumberFormat = "m/dd/yyyy"
wsOut.Columns(colSize).NumberFormat = "#,##0"
wsOut.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
End Sub
Private Function isFolderExcluded(p As Object) As Boolean
Dim i As Long
i = -1
On Error Resume Next
i = Application.WorksheetFunction.Match(UCase(p.Name), aryFoldersToExclude, 0)
On Error GoTo 0
isFolderExcluded = (i <> -1)
End Function
Private Function isFileExcluded(p As Object) As Boolean
Dim i As Long
i = -1
On Error Resume Next
i = Application.WorksheetFunction.Match(UCase(p.Name), aryFilenamesToExclude, 0)
On Error GoTo 0
isFileExcluded = (i <> -1)
End Function
Private Function isSpecificFileExcluded(p As Object) As Boolean
Dim i As Long
i = -1
On Error Resume Next
i = Application.WorksheetFunction.Match(UCase(p.Name), arySpecificFilesToExclude, 0)
On Error GoTo 0
isSpecificFileExcluded = (i <> -1)
End Function
Private Function RemovePrefix(s As String) As String
RemovePrefix = IIf(Left(s, 4) = "\\?\", Right(s, Len(s) - 4), s)
End Function
Private Sub addFileFolder(o As Object)
cntFilesFolders = cntFilesFolders + 1
If cntFilesFolders > UBound(aryFilesFolders) Then
ReDim Preserve aryFilesFolders(1 To UBound(aryFilesFolders) + incFilesFolders)
End If
Set aryFilesFolders(cntFilesFolders) = o
End Sub
