[英]How can i improve my function for handling alternative to Application.FileSearch VBA
I have decided to attempt a UDF around alternative to Application.FileSearch. 我决定尝试使用UDF替代Application.FileSearch。 I assume a few locations where a file COULD be located.
我假设一些文件可能位于的位置。 Solutions on the internet tend to assume the user generally knows where the file is located, this assumed it could be anywhere,
互联网上的解决方案倾向于假设用户通常知道文件的位置,这假设它可以在任何地方,
EDIT: Alot of solutions on the internet are long winded and i believe it should be much more efficient, hence using this post as a means of a discussion as to how this can be achieved 编辑:互联网上的很多解决方案都很长,我相信它应该更有效率,因此使用这篇文章作为讨论如何实现这一目标的一种方式
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
I am happy with the code above but i feel it could be even more dynamic to the point of not having to specify POSSIBLE locations of a file. 我对上面的代码感到满意,但我觉得它可能更加动态,无需指定文件的可能位置。
Please feel free to edit this post as you see fit and contribute your thoughts :) 如果您认为合适,请随时编辑此帖子,并提出您的想法:)
You talk about efficiency, do you mean readability? 你谈到效率,你的意思是可读性吗? Or efficiency in terms of processing power required?
还是要求处理能力方面的效率? The first example is easy enough to read, and change, so I would say that it's readable, but if you know that a file is in, say, one of 3 locations, it would be better to dir each location separately, as in the second example.
第一个例子很容易阅读和更改,所以我会说它是可读的,但是如果你知道一个文件在3个位置中的一个位置,那么最好将每个位置分开,就像在第二个例子。
Regarding the following, it relies on the file in question being inside the "HostFolder" that you specify, so effectively the more precise you can be, the more efficient it will be. 关于以下内容,它依赖于您指定的“HostFolder”中的相关文件,因此有效地越精确,它就越有效。 For example, using the following will be increasingly more efficient:
例如,使用以下内容将越来越有效:
C:\\
C:\\
C:\\Reports
C:\\报告
C:\\Reports\\May
C:\\报告\\五月
Credit to @Rich for his answer here: 感谢@Rich的回答:
Loop Through All Subfolders Using VBA 使用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
I should say though, that this will just open the first instance that it finds of the file named "name.xlsm". 我应该说,这只会打开它找到名为“name.xlsm”的文件的第一个实例。 You need to make modifications if you want to deal with multiple files, although this should be easily possible by storing the potential paths with the
Path.FileDateTime
and opening the most recent. 如果要处理多个文件,则需要进行修改,尽管通过使用
Path.FileDateTime
存储潜在路径并打开最新文件可以轻松实现这一点。
Regarding the second, if you have a shortlist of places to check, then I would use the code below, this is more efficient, but if the file is not in the right location, then it won't work: 关于第二个,如果你有一个要检查的地方的候选名单,那么我会使用下面的代码,这是更有效的,但如果文件不在正确的位置,那么它将无法工作:
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
Whilst I admire the file handling capabilities of Excel VBA, one does miss the trick of shelling to the command line, we can use the DIR
command line tool to print directory results and then process these. 虽然我很欣赏Excel VBA的文件处理功能,但是人们确实错过了对命令行进行炮轰的技巧,我们可以使用
DIR
命令行工具打印目录结果然后处理它们。
Further we can do this asynchronously, that is to say we can shell the process and then go off and do other work (or just allow user to have a responsive session) and when results are ready we process them. 此外,我们可以异步执行此操作,也就是说我们可以对进程进行shell操作然后执行其他工作(或者只是允许用户进行响应会话),并且当结果准备就绪时我们会处理它们。
The DIR Command Line Tool DIR命令行工具
The key switch to the DIR
command line tool is /S
which means process recursively through subdirectories. DIR
命令行工具的键切换是/S
,这意味着通过子目录递归处理。 See dir switches for documentation. 有关文档,请参阅dir开关 。 Also it is critical that one pipes the output to a file so it can be processed by the code.
另外一个关键是将输出传递给文件,以便代码可以处理它。 So the command line (on my computer) looks like this
所以命令行(在我的电脑上)看起来像这样
dir k:\\testDir\\someFile.txt /s > c:\\temp\\dir.txt
where my k drive is set up with some test data and the temp directory is where we write the results file (your temp directory maybe different). 我的k驱动器设置了一些测试数据,临时目录是我们编写结果文件的地方(你的临时目录可能不同)。
But if we are shelling a process in code then we need some extra logic; 但是如果我们在代码中炮制一个进程,那么我们需要一些额外的逻辑; we need to run
cmd.exe
and then pass it the above command line to process. 我们需要运行
cmd.exe
,然后将上面的命令行传递给进程。 We can find where cmd.exe
lives by using the comspec
environment variable. 我们可以使用
comspec
环境变量找到cmd.exe
所在的comspec
。 We also need to pass the /S /C
flags to cmd.exe
here is documentation for that cmd switches 我们还需要将
/S /C
标志传递给cmd.exe
这里是该cmd开关的文档
C:\\WINDOWS\\system32\\cmd.exe /S /C dir k:\\testDir\\someFile.txt /s > c:\\temp\\dir.txt
So we need to run the above command line, I will present two implementations, one synchronous and the other asynchronous. 所以我们需要运行上面的命令行,我将提出两个实现,一个是同步的,另一个是异步的。
Synchronous Implementation 同步实施
The key code is in SyncLaunchShelledCmdDir which shells the command line then calls Windows API for a handle on the shelled process and then wait for it to complete with WaitForSingleObject then we call a subroutine ProcessResultsFile
to do the string handling and parsing of results. 密钥代码在SyncLaunchShelledCmdDir中,它弹出命令行,然后调用Windows API获取shelled进程的句柄,然后等待它完成WaitForSingleObject,然后我们调用子程序
ProcessResultsFile
来执行字符串处理和结果解析。
modSyncShellDir.bas 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 modAsyncShellDir.bas
This implementation is asynchronous, we reuse as much code as possible but to make this work we need to give ourselves some module level variables, also we need to use Application.OnTime
and Application.Run
to handle the polling and the callback. 这个实现是异步的,我们尽可能多地重用代码,但为了使这个工作我们需要给自己一些模块级变量,我们还需要使用
Application.OnTime
和Application.Run
来处理轮询和回调。 This time we do not wait for the process to finish but poll its exit code using the Windows API call GetExitCodeProcess
这次我们不等待进程完成,而是使用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
I hope these are not too long-winded. 我希望这些不是太冗长。 I think it is nice to shell out and get another process to do some work, especially if one can do this asynchronously.
我认为很好地支持并获得另一个进程来完成一些工作,特别是如果可以异步执行此操作。 This is a very useful technique that can make Excel VBA applications very responsive.
这是一种非常有用的技术,可以使Excel VBA应用程序响应迅速。 This is particularly true for notoriously lengthy processes like disc activity.
对于诸如光盘活动这样众所周知的漫长过程尤其如此。
Thanks for setting a bounty! 谢谢你的赏金!
Although I have to agree with @TimWilliams' assessment that "long-winded" doesn't mean "inefficient", if the file is accessed frequently enough you should be able to find it in the .RecentFiles
collection: 虽然我不得不同意@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
Keep in mind that this is a complete hack solution, and I would never use it for anything resembling production code, because the fall-back method if it fails would be similar to either what you posted or @tompreston's answer. 请记住,这是一个完整的黑客解决方案,我永远不会将它用于任何类似于生产代码的东西,因为如果它失败的后退方法将类似于您发布的内容或@ tompreston的答案。
Again, this boils down to what your definition of "efficient" is. 同样,这归结为您对“有效”的定义。 You can query the filesystem with WMI, but this is likely to be horrendously slow in processing time, especially if you don't have everything indexed:
您可以查询与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
You can probably speed this up by "suggesting" directories with an added query filter along the lines of "AND Path IN ('C:\\X\\X\\', 'C:\\X\\X\\X\\')"
, but at that point you're better off with your original solution from the question. 您可以通过“建议”目录添加查询过滤器沿着
"AND Path IN ('C:\\X\\X\\', 'C:\\X\\X\\X\\')"
的行来加快速度,但是那时你最好用问题的原始解决方案。
The correct answer is going to tend toward the "long winded", as that avoids having frustrated end users constantly contacting you when they get strange error dialogs because you chose terse coding over robust code. 正确的答案将倾向于“长篇大论”,因为这样可以避免让沮丧的最终用户在遇到奇怪的错误对话时不断联系您,因为您选择了简洁的代码而不是强大的代码。 "Efficiency" isn't a just measure of how much you have to type.
“效率”并不是衡量你需要输入多少的公正标准。 I'd consider a solution that I never have to provide support for or maintain incredibly efficient.
我会考虑一个解决方案,我永远不会提供支持或保持非常高效。
All, the solution presented below is built from Tom Prestons answer. 总之,下面介绍的解决方案是根据Tom Prestons的回答构建的。 I have given credits where due.
我给了应得的信用。
Key parts to the code: 代码的关键部分:
A check was added to see if the reference to Microsoft Scripting Run Time was already enabled or not.
添加了一项检查,以查看是否已启用对Microsoft Scripting Run Time的引用。 This is essential when running code that requires the scripting.
在运行需要脚本的代码时,这一点至关重要。 This code will be run on a hosts computer and they more often that not will have no reference enabled and thus the code will fail.
此代码将在主机计算机上运行,并且它们通常不会启用任何引用,因此代码将失败。 NB Credit to Is there a code to turn on Microsoft Scripting Runtime Library?
NB感谢是否有代码打开Microsoft Scripting Runtime Library? @Vasily.
@Vasily。 The code was modified to "AddFromFile" as oppose to from GUID.
代码被修改为“AddFromFile”,与GUID相反。 This however assumed that all host computers will contain the scrunn dll in the same location
但是,假设所有主机都将在同一位置包含scrun dll
CODE: 码:
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
Thank you all for your contributions, the Stack Overflow community is excellent! 谢谢大家的贡献,Stack Overflow社区非常棒!
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.