Using an Expression with FSO Get folder

Hi all,

In stead of doing the following

      For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
        If Folder.Name Like Filter Then
          MsgBox Folder.Name

I would like to do something like:

For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
        If Folder.Name Like ([*41B*] |[*41C*][*29X*][*8HW*])   Filter Then
          MsgBox Folder.Name

Is there anyway to get a folder search for a variable instead a constant?


Thanks,

BDB

Hello bdb1974,

You can easily do this kind of filtering using Regular Expressions. Here is an example. You can expand the list as needed. Just follow the rules that I mention and it will work fine.

  Dim FilterList As String
  Dim Folder As Object
  Dim FSO As Object
  Dim RegExp As Object
  
   'Separate filter groups with a pipe character |
   'To include punctuation in a group, precede the character with a foward slash \
   'For example: "2010\-10\-20|41B4|41C|29X|8HW"
    FilterList = "41B|41C|29X|8HW"
    
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.IgnoreCase = True
    RegExp.Pattern = FilterList
    
       For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
        If RegExp.Test(Folder.Name) Then
          MsgBox Folder.Name
        End If
       Next Folder

Thanks Leith. As always, you come back with the right stuff.

In my little puzzle, I'm still missing on piece.


Instead of hardcoding the filterlist as being:

FilterList = "41B|41C|29X|8HW"

I setup a function that parses each word in a string and puts it into an array.
spaces are just one of the delimiters.
Therefore if my entry is: 41B 41C 29X 8HW
My array will result in being 41B|41C|29X|8HW
therfore, arrayCodes() = 41B|41C|29X|8HW

I then want to pass my array through another function MapFolders
This I'm still struggling on getting it setup.
Before I was using:
Cnt = MapFolders("L:\Global\Elec Dept Projects\", "*" & UCase(TextBox1.Value) & "*")

Currently this works with the code you provided:
Cnt = MapFolders("L:\Global\Elec Dept Projects\", UCase(TextBox1.Value))
Where my TextBox1.Value = 41B|41C|29X|8HW

So how can I used the string from the array?
The following gives an error: "Array argument needs to be by Ref"

Cnt = MapFolders("L:\Global\Elec Dept Projects\", (arrayCodes))


If I can reference it to to the array, I will have what I need.

Thanks,

BDB

Hello BDB,

It would help to see all of the code in the Sub or Function. Generally, this error indicates you need to declare arrayCodes in you Sub or Function as a Variant with a Dim statement at the beginning of the procedure.

Public Function restringparse(ByVal inString, Optional ByVal delimiters)
    'Take a string, and return it as a one dimensional array
    ' of individual values as delimited by any of several
    ' characters. None of those characters are returned in
    ' the result. Provide a default list of delimiters, which
    ' should come from registry. But allow override.
 Dim NewInstring As String
    Dim delimitList, oneChar, aWord, codeCount
    Dim arrayCodes()
   Dim OutPL As Worksheet
    Set OutPL = Worksheets(1)
    Dim NewWord As String
    Dim S As Integer
    Dim CMT As Long
    UserForm1.ListBox1.Clear
    
    If IsMissing(delimiters) Then
        'We should get these from Registry
        delimitList = " ,/!|"
'Characters recognized as delimiters

    Else
        delimitList = delimiters
'user can override if needed
    End If
    Dim i, j, k
    i = Len(inString)
    For j = 1 To i
'Read one character at a time
        
        oneChar = VBA.Strings.Mid(inString, j, 1)
        k = InStr(delimitList, oneChar)
'Is this one a delimiter?
        If k = 0 Then
        NewInstring = Right(inString, Len(inString) - j + 1)
        If S = 1 Then
      '  Len(NewInString)
            aWord = ""
            End If
            aWord = aWord & oneChar
            NewWord = aWord & oneChar
            S = 0
        'LastWordLen = Len(aWord)
'If is isn't, add to the current word
        End If
        If k <> 0 Or j = i Then
'If it is, or if we're finished
    If Len(aWord) > "" Then
            'If Len(aWord) = 1 Then
            NewWord = aWord & "|"
           ' ElseIf Len(aWord) >= 2 Then
           ' NewWord = Mid(aWord, Len(NewWord) + 1, Len(aWord) - Len(NewWord))
           ' End If
                codeCount = codeCount + 1
                ReDim Preserve arrayCodes(codeCount)
                arrayCodes(codeCount) = NewWord
            ' arrayCodes (codeCount)
             
'Save new word
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row

 'Sheets(1).Range("A1:A" & UBound(codeCount) + 1) = WorksheetFunction.Transpose(codeCount)
    
    
'Lastrow = Cells.Find(what:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 OutPL.Cells(Lastrow + 1, 1).Value = NewWord
 S = 1
                'aWord = ""
            End If
        End If
    Next j
    If Not codeCount = "" Then
'----------------------------------------------------------------------
 ' Array Fails for ByRef mismatch
    Cnt = MapFolders("L:\Global\Elec Dept Projects\", arrayCodes)
 ' Array Fails for ByRef mismatch
'------------------------------------------------------------------------------------------
'============================================
'This Works. Comment out the previous line and add the following
    'UserForm1.ListBox1.List = WorksheetFunction.Transpose(arrayCodes)
'==================================================
    End If
    restringparse = arrayCodes
'Return the array
End Function

Function MapFolders(DirPath As String, Optional Filter As String, Optional Cnt As Long, Optional aWord As String) As Long
'Written: April 21, 2010
'Updated: May 17, 2010
'Author:  Leith Ross
'Updated:10/21/2010 by BDB
'Summary: Creates a list of all folders and all their subfolders. This list is stored
'         in a public array called "FolderList". The macro returns the number of folders
'         matching the filter. If no filter is specified then all folders are returned.
'Dim FolderList() As Variant

  
  Dim FSO As Object
  Dim Folder As Object
    Dim WordSearch As String
    Dim FilterList As String
  Dim RegExp As Object
  
  
    If FSO Is Nothing Then
       Set FSO = CreateObject("Scripting.FileSystemObject")
    End If
    
   
    If Len(Filter) > 0 Then
     'MsgBox "Filter2"
     'On Error Resume Next
    '  For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
     ' If Instr(Folder.name,Filter)
      '  If Folder.Name Like [Filter|WordSearch] Then
     '   If Folder.Name Like Filter Then
        
        
 
   

 
   '   -------------------------------------------------
   'Separate filter groups with a pipe character |
   'To include punctuation in a group, precede the character with a foward slash \
   'For example: "2010\-10\-20|41B4|41C|29X|8HW"
  ' ----------------------------------------------------

   ' FilterList = "41B|41C|29X|8HW"
    FilterList = Filter
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.IgnoreCase = True
    RegExp.Pattern = FilterList

  

    If FSO Is Nothing Then
       Set FSO = CreateObject("Scripting.FileSystemObject")
    End If
  
 ' Older Method =========================
  ' For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
      '  If Folder.Name Like Filter Then
'-------------------------------------------------------------------
 ' New Method
        
          For Each Folder In FSO.GetFolder(DirPath).SubFolders  '& SubFolders)
        If RegExp.test(Folder.Name) Then

       ' If Folder.Name Like [*41B*] Then
         ' MsgBox Folder.Name
           ReDim Preserve FolderList(Cnt)
           FolderList(Cnt) = Folder.Path
           Cnt = UBound(FolderList) + 1
        End If
        If Folder.SubFolders.Count > 0 Then
        'MsgBox "I'm Here."
           MapFolders Folder.Path, Filter, Cnt
           End If
      Next Folder
      Else
      MsgBox "You must enter a character string for a word or phrase to be be searched"
     Set FSO = Nothing
      'Exit Sub
      Exit Function
      End If


    MapFolders = Cnt
  
   ' If OptionButton1 = True And Cnt > 0 Then
   If Cnt > 0 Then
      UserForm1.ListBox1.List = WorksheetFunction.Transpose(FolderList)
    End If
    
    Set FSO = Nothing
   
End Function

Instead of my module code passing the string onto the mapfolder function, it goes first to restringparse function first. Then the array needs to be passed onto the mapfolder as the newstring to map. It then outputs to listbox the folder paths for each like expression matched/found.

Thanks,

BDB