如何改進我的功能來處理Application.FileSearch VBA的替代方案

Question

我決定嘗試使用UDF替代Application.FileSearch。 我假設一些文件可能位於的位置。 互聯網上的解決方案傾向於假設用戶通常知道文件的位置，這假設它可以在任何地方，

編輯：互聯網上的很多解決方案都很長，我相信它應該更有效率，因此使用這篇文章作為討論如何實現這一目標的一種方式

Please note, I have replaced the path directories with an 'X' and the file name is just "File Name"

Public Function FindFile()

If Len(Dir("C:\X\X\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\X\X\File Name.xlsm"), UpdateLinks:=False

ElseIf Len(Dir("C:\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\File Name.xlsm"), UpdateLinks:=False

ElseIf Len(Dir("C:\X\X\File Name.xlsm", vbDirectory)) <> 0 Then
    Workbooks.Open ("C:\X\X\File Name.xlsm"), UpdateLinks:=False

End If

End Function

我對上面的代碼感到滿意，但我覺得它可能更加動態，無需指定文件的可能位置。

如果您認為合適，請隨時編輯此帖子，並提出您的想法:)

Answer 1

你談到效率，你的意思是可讀性嗎？ 還是要求處理能力方面的效率？ 第一個例子很容易閱讀和更改，所以我會說它是可讀的，但是如果你知道一個文件在3個位置中的一個位置，那么最好將每個位置分開，就像在第二個例子。

關於以下內容，它依賴於您指定的“HostFolder”中的相關文件，因此有效地越精確，它就越有效。 例如，使用以下內容將越來越有效：

C：\\

C：\\報告

C：\\報告\\五月

感謝@Rich的回答：

使用VBA循環遍歷所有子文件夾

Sub MainBeast()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\mypath\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "Name.xlsm" Then
            Workbooks.Open (Folder.Path & "\" & "Name.xlsm"), UpdateLinks:=False
            Workbooks("Name.xlsm").Activate
            Exit Sub
        End If
    Next
End Sub

我應該說，這只會打開它找到名為“name.xlsm”的文件的第一個實例。 如果要處理多個文件，則需要進行修改，盡管通過使用Path.FileDateTime存儲潛在路徑並打開最新文件可以輕松實現這一點。

關於第二個，如果你有一個要檢查的地方的候選名單，那么我會使用下面的代碼，這是更有效的，但如果文件不在正確的位置，那么它將無法工作：

sub MainBeast()
    if fileExists("C:\" & "Name.xlsm") then Workbooks.Open ("C:\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locA\" & "Name.xlsm") then Workbooks.Open ("C:\locA\" & "Name.xlsm"), UpdateLinks:=False
    if fileExists("C:\locB\" & "Name.xlsm") then Workbooks.Open ("C:\locB\" & "Name.xlsm"), UpdateLinks:=False
End Sub
Function FileExists(ByVal FullPath As String) As Boolean
If dir(FullPath) <> "" Then
    FileExists = True
Else
    FileExists = False
End If
End Function

Answer 2

雖然我很欣賞Excel VBA的文件處理功能，但是人們確實錯過了對命令行進行炮轟的技巧，我們可以使用DIR命令行工具打印目錄結果然后處理它們。

此外，我們可以異步執行此操作，也就是說我們可以對進程進行shell操作然后執行其他工作（或者只是允許用戶進行響應會話），並且當結果准備就緒時我們會處理它們。

DIR命令行工具

DIR命令行工具的鍵切換是/S ，這意味着通過子目錄遞歸處理。 有關文檔，請參閱dir開關 。 另外一個關鍵是將輸出傳遞給文件，以便代碼可以處理它。 所以命令行（在我的電腦上）看起來像這樣

dir k:\\testDir\\someFile.txt /s > c:\\temp\\dir.txt

我的k驅動器設置了一些測試數據，臨時目錄是我們編寫結果文件的地方（你的臨時目錄可能不同）。

但是如果我們在代碼中炮制一個進程，那么我們需要一些額外的邏輯; 我們需要運行cmd.exe ，然后將上面的命令行傳遞給進程。 我們可以使用comspec環境變量找到cmd.exe所在的comspec 。 我們還需要將/S /C標志傳遞給cmd.exe這里是該cmd開關的文檔

C:\\WINDOWS\\system32\\cmd.exe /S /C dir k:\\testDir\\someFile.txt /s > c:\\temp\\dir.txt

所以我們需要運行上面的命令行，我將提出兩個實現，一個是同步的，另一個是異步的。

同步實施

密鑰代碼在SyncLaunchShelledCmdDir中，它彈出命令行，然后調用Windows API獲取shelled進程的句柄，然后等待它完成WaitForSingleObject，然后我們調用子程序ProcessResultsFile來執行字符串處理和結果解析。

modSyncShellDir.bas

Option Explicit

Private Const msRESULTSFILE As String = "c:\temp\dirSync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Const INFINITE = &HFFFF

Private Sub UnitTestSyncLaunchShelledCmdDir()
    SyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt"
End Sub

Private Sub SyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub SyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"


    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    Dim lShelledCmdDir As Long
    lShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)

    Dim hProc As Long
    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, lShelledCmdDir)

    If hProc <> 0 Then
        WaitForSingleObject hProc, INFINITE

        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)
        SyncSampleProcessResults vResults

    End If
    CloseHandle hProc

End Sub

Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
        Dim sSlice As String
        sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


        dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys


End Function

Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

modAsyncShellDir.bas
這個實現是異步的，我們盡可能多地重用代碼，但為了使這個工作我們需要給自己一些模塊級變量，我們還需要使用Application.OnTime和Application.Run來處理輪詢和回調。 這次我們不等待進程完成，而是使用Windows API調用GetExitCodeProcess輪詢其退出代碼

Option Explicit

Private mlShelledCmdDir As Double
Private msFileNameToLookFor As String
Private msCallbackFunction As String

Private Const msRESULTSFILE As String = "c:\temp\dirAsync.txt"
Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal lnghProcess As Long, lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Sub UnitTestAsyncLaunchShelledCmdDir()
    AsyncLaunchShelledCmdDir "k:\testDir\", "someFile.txt", "AsyncSampleProcessResults"
End Sub


Private Sub AsyncSampleProcessResults(ByVal vResults As Variant)
    '*** YOUR CODE GOES HERE
    Dim vLoop As Variant
    For Each vLoop In vResults
        Debug.Print vLoop
    Next
End Sub

Private Sub AsyncLaunchShelledCmdDir(ByVal sTopLevelDirectory As String, ByVal sFileNameToLookFor As String, ByVal sCallbackFunction As String)
    Debug.Assert Right$(sTopLevelDirectory, 1) = "\"
    msFileNameToLookFor = sFileNameToLookFor
    msCallbackFunction = sCallbackFunction
    Dim sCmd As String
    sCmd = VBA.Environ$("comspec") & " /S /C"
    mlShelledCmdDir = VBA.Shell(sCmd & "  dir " & sTopLevelDirectory & sFileNameToLookFor & " /s > " & msRESULTSFILE)


    Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
End Sub

Private Sub PollLaunchShelledCmdDir()
    If Not IsLaunchShelledCmdDirRunning Then
        Dim sFileContents As String
        sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall

        Dim vResults As Variant
        vResults = ProcessResultsFile(sFileContents, msFileNameToLookFor)
        Application.Run msCallbackFunction, vResults
    Else
        Application.OnTime Now() + CDate("00:00:01"), "PollLaunchShelledCmdDir"
    End If
End Sub


Private Function IsLaunchShelledCmdDirRunning() As Boolean
    Dim hProc As Long
    Dim lExitCode As Long
    Dim lRet As Long

    hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, mlShelledCmdDir)
    If hProc <> 0 Then
        GetExitCodeProcess hProc, lExitCode
        IsLaunchShelledCmdDirRunning = (lExitCode <> 0)
    End If
    CloseHandle hProc

End Function




Private Function ProcessResultsFile(ByVal sFileContents As String, ByVal sFileNameToLookFor As String) As Variant

    Dim dic As Object
    Set dic = VBA.CreateObject("Scripting.Dictionary")

    Dim lFindFileName As Long
    lFindFileName = VBA.InStr(1, sFileContents, sFileNameToLookFor, vbTextCompare)

    While lFindFileName > 0
        '* found something so step back and get previous "Directory of"

        Dim lPreviousDirectoryOfPos As Long
        lPreviousDirectoryOfPos = VBA.InStrRev(sFileContents, "Directory of ", lFindFileName + 1, vbTextCompare)

        Dim lDirectoryStringBeginningPos As Long
        lDirectoryStringBeginningPos = lPreviousDirectoryOfPos + Len("Directory of ")

        Dim lNextLineFeedAfterPreviousDirectoryOfPos As Long
        lNextLineFeedAfterPreviousDirectoryOfPos = VBA.InStr(lDirectoryStringBeginningPos, sFileContents, vbNewLine, vbTextCompare)
        If lNextLineFeedAfterPreviousDirectoryOfPos > 0 Then
            Dim sSlice As String
            sSlice = Mid(sFileContents, lDirectoryStringBeginningPos, lNextLineFeedAfterPreviousDirectoryOfPos - lDirectoryStringBeginningPos)


            dic.Add sSlice, 0

        End If

        lFindFileName = VBA.InStr(lFindFileName + 1, sFileContents, sFileNameToLookFor, vbTextCompare)

    Wend

    ProcessResultsFile = dic.keys
End Function


Private Sub UnitTestProcessResultsFile()
    Dim sFileNameToLookFor As String
    sFileNameToLookFor = "someFile.txt"

    Dim sFileContents As String
    sFileContents = VBA.CreateObject("Scripting.FileSystemObject").OpenTextFile(msRESULTSFILE).readall
    Dim vResults As Variant
    vResults = ProcessResultsFile(sFileContents, sFileNameToLookFor)

End Sub

我希望這些不是太冗長。 我認為很好地支持並獲得另一個進程來完成一些工作，特別是如果可以異步執行此操作。 這是一種非常有用的技術，可以使Excel VBA應用程序響應迅速。 對於諸如光盤活動這樣眾所周知的漫長過程尤其如此。

謝謝你的賞金！

Answer 3

選項1 - RecentFiles

雖然我不得不同意@TimWilliams的評估，即“啰嗦”並不意味着“低效”，如果文件被頻繁訪問，你應該能夠在.RecentFiles集合中找到它：

Public Function FindFile() As String
    Dim x As Variant
    For Each x In Application.RecentFiles
        If x.Name Like "*File Name.xlsm" Then
            FindFile = x.Name
            Exit Function
        End If
    Next x
End Function

請記住，這是一個完整的黑客解決方案，我永遠不會將它用於任何類似於生產代碼的東西，因為如果它失敗的后退方法將類似於您發布的內容或@ tompreston的答案。

---

選項2 - WMI

同樣，這歸結為您對“有效”的定義。 您可以查詢與WMI文件系統，但是這很可能是在處理時的窘況緩慢，特別是如果你沒有一切索引：

Public Function FindFile() As String
    With CreateObject("winmgmts:root/CIMV2")
        Dim results As Object, result As Object, query As String
        query = "SELECT TOP 1 * FROM Cim_DataFile WHERE Filename = 'File Name' AND Extension = 'xlsm'"
        Set results = .ExecQuery(query)
        For Each result In results
            FindFile = result.Path & "File Name.xlsm"
            Exit Function
        Next
    End With
End Function

您可以通過“建議”目錄添加查詢過濾器沿着"AND Path IN ('C:\\X\\X\\', 'C:\\X\\X\\X\\')"的行來加快速度，但是那時你最好用問題的原始解決方案。

---

正確的答案將傾向於“長篇大論”，因為這樣可以避免讓沮喪的最終用戶在遇到奇怪的錯誤對話時不斷聯系您，因為您選擇了簡潔的代碼而不是強大的代碼。 “效率”並不是衡量你需要輸入多少的公正標准。 我會考慮一個解決方案，我永遠不會提供支持或保持非常高效。

Answer 4

總之，下面介紹的解決方案是根據Tom Prestons的回答構建的。 我給了應得的信用。

代碼的關鍵部分：

• 添加了一項檢查，以查看是否已啟用對Microsoft Scripting Run Time的引用。 在運行需要腳本的代碼時，這一點至關重要。 此代碼將在主機計算機上運行，​​並且它們通常不會啟用任何引用，因此代碼將失敗。 NB感謝是否有代碼打開Microsoft Scripting Runtime Library？ @Vasily。 代碼被修改為“AddFromFile”，與GUID相反。 但是，假設所有主機都將在同一位置包含scrun dll

---

• HostFolder非常高級。 從那里，必須搜索相當數量的子文件夾，但不幸的是我需要在這個級別。 對於閱讀此內容的任何人，如果您100％確定客戶端不會將密鑰文件移動到HostFolder的外部位置，請使其更加具體，以加快運行時間
• 通過“應用程序”優化代碼。 （公平地說，由於某種原因它沒有什么區別，沒有它需要40秒並且需要c32秒）
• 用File.Name替換Workbooks.Open命令，而不是實際引用文件名
• 全局聲明的所有變量（更清潔）

碼：

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Dim Ref As Object, CheckRefEnabled%
Sub FindFile()
HostFolder = "F:\x\x\"

CheckRefEnabled = 0
With ThisWorkbook
    For Each Ref In .VBProject.References
        If Ref.Name = "Scripting" Then
            CheckRefEnabled = 1
            Exit For
        End If
    Next Ref
    If CheckRefEnabled = 0 Then
        .VBProject.References.AddFromFile ("C:\Windows\System32\scrrun.dll")
    End If
End With

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

End Sub
Sub DoFolder(Folder)

With Application
    .EnableEvents = False
    .DisplayStatusBar = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If File.Name = "y.xlsm" Then
            Workbooks.Open (Folder.path & "\" & File.Name), UpdateLinks:=False
            Workbooks(File.Name).Activate
            Exit Sub
        End If
    Next

With Application
    .EnableEvents = True
    .DisplayStatusBar = True
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

謝謝大家的貢獻，Stack Overflow社區非常棒！