Рекурсивный поиск по подпапкам НАЗАД в корневой каталог - PullRequest
Новая
       14

Рекурсивный поиск по подпапкам НАЗАД в корневой каталог

0 голосов
/ 11 декабря 2018

У меня есть функция, которая работает для поиска в подпапках данного каталога и находит нужное имя файла.Тем не менее, он проходит только через один набор подпапок, находит первую и затем проходит до конца подпапок.Однако тогда он просто останавливается.Я просматривал различные темы и пробовал разные варианты, но без радости.

Мне нужно, чтобы затем вернуться к корневому каталогу (скажем, sPath = C: \ Windows) и просмотреть следующую подпапку, просмотреть весь этот каталог, вернуться в корневую папку и т. Д.пока он не найдет нужный файл.Кажется, я не могу заставить эту часть работать, надеясь, что кто-то здесь может помочь указать на то, что мне не хватает.Я пытаюсь сохранить этот набор в корневой папке более высокого уровня, вместо того, чтобы начинать работу в каталоге ниже, чтобы он заработал.Вот функция: 

Function recurse(sPath As String, strname As String, strName3 As String)

Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder
Dim mySubFolder As Scripting.Folder
Dim myFile As Scripting.file    

Dim strJDFile As String
Dim strDir As String
Dim strJDName As String

Set myFolder = FSO.GetFolder(sPath)

' strName = Range("a2").Offset(0, 3)
strName3 = Replace(strName3, "/", " ")

For Each mySubFolder In myFolder.SubFolders
Debug.Print " mySubFolder: " & mySubFolder

For Each myFile In mySubFolder.Files        

    If "*" & myFile.Name & "*" Like "*" & strName3 & "*" Then
        strJDName = myFile.Name
        strDir = mySubFolder & "\"
        strJDFile = strDir & strJDName

        recurse = strJDFile

        Exit Function

    Else
        Debug.Print "  myFile.name: " & myFile.Name
    End If

Next

recurse = recurse(mySubFolder.Path, strname, strName3)

Next

End Function

1 Ответ

0 голосов
/ 11 декабря 2018

Вот процедура, которую вы можете адаптировать к своему использованию, если вы используете Excel под Windows.

  • Выбор базовой папки с помощью процедуры выбора папки Excel
  • Введите маску имени файла (например: Book1.xls*)
  • Использует команду окна команды Dir, чтобы проверить все папки и подпапки для файлов, которые начинаются с Book1.xls
  • Результаты команды записываются во временный файл (который удаляется в конце макроса)
    • Есть способ записать его непосредственно в переменную VBA, но я вижу слишком много экранамерцание, когда я это сделал.
  • Затем результаты собираются в массив vba и записываются на лист, но вы можете делать с результатами все, что захотите. 
Option Explicit
'set references to
'   Microsoft Scripting Runtime
'   Windows Script Host Object model
Sub FindFile()
    Dim WSH As WshShell, lErrCode As Long
    Dim FSO As FileSystemObject, TS As TextStream
    Dim sTemp As String
    Dim sBasePath As String
    Dim vFiles As Variant, vFullList() As String
    Dim I As Long
    Dim sFileName As String

    sTemp = Environ("Temp") & "\FileList.txt"

'Select base folder
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then 'if OK is pressed
        sBasePath = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

'File name mask
sFileName = InputBox("Entire File Mask", "File Finder")

Set WSH = New WshShell
lErrCode = WSH.Run("CMD /c dir """ & sBasePath & "\*" & sFileName & """ /A-D /B /S > " & sTemp, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Problem Reading Directory" & _
        vbLf & "Error Code " & lErrCode
    Exit Sub
End If


Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTemp, ForReading, False, TristateFalse)

vFiles = Split(TS.ReadAll, vbLf)
TS.Close
FSO.DeleteFile sTemp
Set FSO = Nothing
Set WSH = Nothing

ReDim vFullList(1 To UBound(vFiles), 1 To 1)
For I = 1 To UBound(vFiles)
    vFullList(I, 1) = vFiles(I)
Next I

Dim rDest As Range
Set rDest = Cells(1, 2).Resize(UBound(vFullList, 1), UBound(vFullList, 2))

With rDest
    .EntireColumn.Clear
    .Value = vFullList
    .EntireColumn.AutoFit
End With

End Sub
...