Apply existing VBS folder search to sub folders?

问题:

I am using the following code to search a folder for a file name, open the file run an excel macro, save the file, and close. I would like to extend this to loop through sub folders and do the same. There should only be one layer of sub folders but multiple folders in that layer.

dir = "C:\Users\ntunstall\Desktop\test"

Sub RunMacroAndSaveAs(file, macro)
  Set wb = app.Workbooks.Open(file)
  app.Run wb2.Name & "!" & macro
  wb.SaveAs fso.BuildPath(file.ParentFolder, fso.GetBaseName(file) & ".xlsm"), 52
  wb.Close
End Sub

Set fso = CreateObject("Scripting.FileSystemObject")
Set app = CreateObject("Excel.Application")
app.Visible       = False
app.DisplayAlerts = False
Set wb2 = app.Workbooks.Open("C:\Users\ntunstall\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB")

For Each file In fso.GetFolder(dir).Files
  If InStr(file.Name, "OPS") > 0 Then
    RunMacroAndSaveAs file, "Main"
  ElseIf InStr(file.Name, "Event") > 0 Then
    RunMacroAndSaveAs file, "Events"
  End If
Next
wScript.Quit
app.Quit

How can I modify this code to search sub folders?

Solution:

dir = "C:\Users\ntunstall\Desktop\test"

Sub RunMacroAndSaveAs(file, macro)
  Set wb = app.Workbooks.Open(file)
  Set wb2 = app.Workbooks.Open("C:\Users\ntunstall\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB")
  app.Run wb2.Name & "!" & macro
  wb.SaveAs fso.BuildPath(file.ParentFolder, fso.GetBaseName(file) & ".xlsm"), 52
  wb.Close
End Sub

Set fso = CreateObject("Scripting.FileSystemObject")
Set app = CreateObject("Excel.Application")
app.Visible = False

Dim path: path = "C:\Users\ntunstall\Desktop\test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
'Call this to trigger the recursion.
Call TraverseFolders(fso.GetFolder(path))

Sub TraverseFolders(fldr)
  Dim f, sf
  ' do stuff with the files in fldr here, or ...
  For Each f In fldr.Files
    If InStr(f.Name, "OPS") > 0 Then
      Call RunMacroAndSaveAs(f, "Main")
    ElseIf InStr(f.Name, "Event") > 0 Then
      Call RunMacroAndSaveAs(f, "Events")
    End If
  Next
  For Each sf In fldr.SubFolders
    Call TraverseFolders(sf)  '<- recurse here
  Next
  ' ... do stuff with the files in fldr here.
End Sub

wScript.Quit
app.Quit

回答1:

Well, apparently I'm not helpful...

Dim path: path = "C:\Users\ntunstall\Desktop\test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
'Call this to trigger the recursion.
Call TraverseFolders(fso.GetFolder(path))

Sub TraverseFolders(fldr)
  Dim f, sf
  ' do stuff with the files in fldr here, or ...
  For Each f In fldr.Files
    If InStr(f.Name, "OPS") > 0 Then
      Call RunMacroAndSaveAs(f, "Main")
    ElseIf InStr(f.Name, "Event") > 0 Then
      Call RunMacroAndSaveAs(f, "Events")
    End If
  Next
  For Each sf In fldr.SubFolders
    Call TraverseFolders(sf)  '<- recurse here
  Next

  ' ... do stuff with the files in fldr here.
End Sub

Taken from the method by @ansgar-wiechers - A: Recursively access subfolder files inside a folder which I already flagged as a duplicate.

Have tested this using

WScript.Echo f.Name

in place of the RunMacroAndSaveAs() Sub Procedure if it is still erroring the issue lies there as this recursion works fine.

回答2:

Steps towards the solution:

1. Create the following method:

   Sub IterateFolder(dir, fso)
     For Each file In fso.GetFolder(dir).Files
       If InStr(file.Name, "OPS") > 0 Then
         RunMacroAndSaveAs file, "Main"
       ElseIf InStr(file.Name, "Event") > 0 Then
         RunMacroAndSaveAs file, "Events"
       End If
     Next
   End Sub`
   

and call it like this: IterateFolder "C:\Users\ntunstall\Desktop\test", fso

This will still do this for the first level, but do this as a first step and understand it.

2. Understand fso.SubFolders

3. Apply the new knowledge:

   Sub IterateFolder(dir, fso)
     For Each file In fso.GetFolder(dir).Files
       If InStr(file.Name, "OPS") > 0 Then
         RunMacroAndSaveAs file, "Main"
       ElseIf InStr(file.Name, "Event") > 0 Then
         RunMacroAndSaveAs file, "Events"
       End If
     Next
     For Each sf In fso.SubFolders
       IterateFolder sf, fso
     Next
   End Sub
   

I do not work with VBScript, therefore I am not 100% sure if I'm right. If you have any problems with the solution, please ask.

EDIT:

As pointed out in the commenting section, fso is a variable which was out of scope in the Sub. I have edited my answer to make sure it is passed.

EDIT2:

Let's hope this is the coup de grace. I was mistaken in the way subfolders were iterated. Change this chunk:

For Each sf In fso.SubFolders
  IterateFolder sf, fso
Next

to this:

For Each sf In fso.GetFolder(dir).SubFolders
  IterateFolder sf, fso
Next

EDIT3:

We need to check SubFolders against null. According to this source, we should change this:

For Each sf In fso.GetFolder(dir).SubFolders
  IterateFolder sf, fso
Next

to this:

If Not IsNull(fso.GetFolder(dir).SubFolders) Then
  For Each sf In fso.GetFolder(dir).SubFolders
    IterateFolder sf, fso
  Next
End If