List matching files with wildcards in VBS (Visual Basic Script), supports multiple wildcards in folder and filenames

ListMatchingFiles.vbs

Option Explicit


Class ListMatchingFiles
    Public pathList
    ' saves an array in var pathList with the file names that match the given path
    ' The Path string may contain the wildcard characters "*"
    ' and "?" in the file name component.
    ' Widcard * is allowed in Folder and Filenames, eg. "H:\home\*\work\*\*abc*.err"
    ' If Path is a directory, the contents of this directory is listed.
    ' If Path is empty, the current directory is listed.
    ' Original Code from http://www.source-code.biz/snippets/vbscript/1.htm , wildcard support extended
    ' Example:
        ' checkFtSearchDirectories = Array("H:\My Documents\*\*\work\*abc*.err", "H:\My Documents\test\*\Prod\error\*")
        ' For Each folderDir In checkFtSearchDirectories
        '     Dim searcher : set searcher = New ListMatchingFiles
        '     searcher.Run folderDir
        '     If searcher.pathList.Count > 0 Then ' check path list if some files were found
        '        Dim resfile
        '        For Each resfile In searcher.pathList ' print warning for each dumpfile
        '            WScript.echo "found: " & resfile
        '        Next
        '     End If
        ' Next
    Public Function ListDir (ByVal Path)
        'WScript.echo "Path: " & Path 'debug
        Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
        If Path = "" Then Path = "*.*"
        'WScript.echo "Path2: " & Path 'debug
        ' WScript.echo "ListDir: Path: " & Path
        ' If path contains * call listdir with all subfolders of parentfolder of *
        Dim starPos, starRight, starLeft
        starPos = InStr(Path, "*")
        If starPos > 0 Then
            ' check If * is surrounded by "\"
            starPos = InStr(Path, "*")
            ' WScript.echo "ListDir: starPos: " & starPos
            Dim starParentFolder, starSubFolder, starDissolvedPath, starLeftPath, starRightPath
            starLeftPath = Left(Path, starPos-2)
            starRightPath = Right(Path, Len(Path)-starPos)
            starRight = Mid(Path,starPos+1,1)
            starLeft = Mid(Path,starPos-1,1)
            ' WScript.echo "ListDir: starRight: " & starRight & " starLeft: " & starLeft
            'If (starLeft = "\" And starRight = "\") Then
            'WScript.Echo "ListDir: starLeftPath: " & starLeftPath & " starRightPath: " & starRightPath
            If (starLeft = "\" And starRight = "\") Then
                If Not fso.FolderExists(starLeftPath) Then 
                    'WScript.echo "ListMatchingFiles: INFORMATION: Folder " & starLeftPath & " doesnt exists.. EXIT!"
                    Exit Function
                End If         
                set starParentFolder = fso.GetFolder(starLeftPath)
                 'WScript.Echo "ListDir: starParentFolder: " & starParentFolder & " SubFolders: " & starParentFolder.SubFolders.count
                For Each starSubFolder In starParentFolder.SubFolders ' go through all subfolders
                    'WScript.Echo "ListDir: starSubFolder: " & starSubFolder & " starLeftPath: " & starLeftPath & " starRightPath: " & starRightPath
                    ' If starRightPath is empty, than all files and folders are matched, return path
                    ' Create full paths without *
                    starDissolvedPath = starSubFolder.Path + starRightPath
                    'WScript.Echo "ListDir: starDissolvedPath: " & starDissolvedPath
                    ListDir(starDissolvedPath)
                Next
                ' Exit Function here because all subfolders are listed
                 'WScript.echo "ListMatchingFiles: INFORMATION: All subfolders are listed! EXIT!"
                Exit Function
            Else ' check If parent folder contains any subfolder if(left = / and right = "")
                If (starLeft = "\" And starRight = "") Then
                    If fso.FolderExists(starLeftPath) Then 
                        'WScript.echo "ListMatchingFiles: Folder " & starLeftPath & " exists.. "
                        set starParentFolder = fso.GetFolder(starLeftPath)   
                        'WScript.Echo "ListDir: starParentFolder: " & starParentFolder & " SubFolders: " & starParentFolder.SubFolders.count
                        For Each starSubFolder In starParentFolder.SubFolders ' go through all subfolders
                            'WScript.Echo "ListDir: starSubFolder: " & starSubFolder 
                            'WScript.echo "ListDir: ADD FILE: " & starSubFolder.path
                            pathList.Add starParentFolder.path
                        Next
                    End If  
                End If
            End If
        End If
        Dim Parent, Filter
        If fso.FolderExists(Path) Then      ' Path is a directory
            ' WScript.echo "ListDir: Folder exists"
            Parent = Path
            Filter = "*"
        Else
            Parent = fso.GetParentFolderName(Path)
            If Parent = "" Then If Right(Path,1) = ":" Then Parent = Path: Else Parent = "."
            Filter = fso.GetFileName(Path)
            If Filter = "" Then Filter = "*"
        End If
        'WScript.Echo  "ListDir: Parent folder path: " & Parent
        If Not fso.FolderExists(Parent) Then      ' Path is a directory
            'WScript.echo "ListMatchingFiles: INFORMATION: Parentfolder >"&Parent&"< dont exists! EXIT!"
            Exit Function
        End If
        Dim Folder: Set Folder = fso.GetFolder(Parent)
        'WScript.echo "ListDir: Parent folder: " & Folder
        Dim Files: Set Files = Folder.Files
        Dim File
        For Each File In Files
            If CompareFileName(File.Name,Filter) Then
                'WScript.echo "ListDir: ADD FILE: " & File.path
                pathList.Add File.Path
            End If
        Next
    End Function

    Private Function CompareFileName (ByVal Name, ByVal Filter) ' (recursive)
        'WScript.echo "CompareFileName: Name: " & Name & " Filter: " & Filter
        CompareFileName = False
        Dim np, fp: np = 1: fp = 1
        Do
            If fp > Len(Filter) Then CompareFileName = np > len(name): Exit Function
            If Mid(Filter,fp) = ".*" Then    ' special case: ".*" at end of filter
                If np > Len(Name) Then CompareFileName = True: Exit Function
            End If
            If Mid(Filter,fp) = "." Then     ' special case: "." at end of filter
                CompareFileName = np > Len(Name): Exit Function
            End If
            Dim fc: fc = Mid(Filter,fp,1): fp = fp + 1
            Select Case fc
                Case "*"
                    CompareFileName = CompareFileName2(name,np,filter,fp)
                Exit Function
                Case "?"
                    If np <= Len(Name) And Mid(Name,np,1) <> "." Then np = np + 1
                Case Else
                    If np > Len(Name) Then Exit Function
                    Dim nc: nc = Mid(Name,np,1): np = np + 1
                If Strcomp(fc,nc,vbTextCompare)<>0 Then Exit Function
            End Select
        Loop
    End Function

    Private Function CompareFileName2 (ByVal Name, ByVal np0, ByVal Filter, ByVal fp0)
        'WScript.echo "CompareFileName2: Name: " & Name & " Filter: " & Filter & " fp0: " & fp0
        Dim fp: fp = fp0
        Dim fc2
        Do                                  ' skip over "*" and "?" characters in filter
            If fp > Len(Filter) Then CompareFileName2 = True: Exit Function
            fc2 = Mid(Filter,fp,1): fp = fp + 1
            If fc2 <> "*" And fc2 <> "?" Then Exit Do
            Loop
                If fc2 = "." Then
                    If Mid(Filter,fp) = "*" Then     ' special case: ".*" at end of filter
                        CompareFileName2 = True: Exit Function
                    End If
                    If fp > Len(Filter) Then         ' special case: "." at end of filter
                        CompareFileName2 = InStr(np0,Name,".") = 0: Exit Function
                    End If
                End If
                Dim np
                For np = np0 To Len(Name)
                    Dim nc: nc = Mid(Name,np,1)
                    If StrComp(fc2,nc,vbTextCompare)=0 Then
                        If CompareFileName(Mid(Name,np+1),Mid(Filter,fp)) Then
                            CompareFileName2 = True: Exit Function
                        End If
                    End If
            Next
        CompareFileName2 = False
    End Function

    ' Reduce filelist to list of distinct folderpaths to minimize output list
    ' Helpfull to print only the folders which contain the searched files
    Public Sub ReduceToDistinctPaths()
        Dim reducedList  : Set reducedList = CreateObject("System.Collections.ArrayList")
        If pathList.Count > 0 Then ' check path list If some files were found
            Dim fullPath, starPos, lastSlashPos, reducedPath, searchPath, dismissPath
            For Each fullPath In pathList ' print warning for each dumpfile
                WScript.echo "fullPath: " & fullPath
                lastSlashPos = InStrRev(fullPath, "\") ' get position last slash
                reducedPath = Left(fullPath, lastSlashPos) ' get path without last file/folder
                'WScript.echo "redPath: " & reducedPath
                ' check If reducedPath is in reducedList, If Not add path
                dismissPath = false
                For Each searchPath in reducedList
                    If (StrComp(searchPath,reducedPath) = 0) Then
                        dismissPath = true ' path found, is allready in list, therefore dismiss it
                    End If    
                Next
                If Not dismissPath Then
                    'WScript.echo "reducedList add " & reducedPath
                    reducedList.add reducedPath
                End If
            Next
            set pathList = reducedList
        End If
    End Sub

    ' Run(PathToSearch)
    Public Sub Run(sPath)
        Set pathList = CreateObject("System.Collections.ArrayList")
        Call ListDir(sPath)
    End Sub
End Class

It is a nice code; however, it will break under Windows 10 if ".NET Framework 3.5" is not installed.
"System.Collections.ArrayList" is not available in the newer versions :-(

In case that somebody needs this code, but doesn't want to install .Net 3.5, then a quick and dirty solution would be to use a "Scripting.Dictionary" object instead. So, you will have to replace the following calls:

• CreateObject("System.Collections.ArrayList") by: CreateObject("Scripting.Dictionary")
• obj.add path by: obj.add path, ""
• For Each key In obj by: For Each key In obj.Keys()