具有子目录的最佳查找文件
我一直在四处寻找，找不到搜索包含子目录的文件的方法 ；Excel有一个.FileSearch方法，但它没有#039；有什么想法吗？不检查每个目录中的其他目录，然后检查它们，I'；我不确定。 最好的当然不是，这是我大约一百年前写的（don #039；t笑）。你认为合适的虐待
Option Explicit
Public Sub Test ( )
Dim foldername As String, _
filespec As String, _
var As Variant
foldername = "c:\windows\temp"
''you could use this to reduce the initial scan results
filespec = "*.*"
''in a real world app you'd want to set the result to a collection
''and then test the count before attempting to iterate it
For Each var In GetAllFiles(foldername, filespec, True)
Debug.Print var
''do your final file matching code here if filespec doesn't nail it
Next var
End Sub
Public Function GetAllFiles(foldername As String, filespec As String, recurse As Boolean) As Collection
Dim result As New Collection
Call GetAllFilesEx(foldername, filespec, recurse, result)
Set GetAllFiles = result
End Function
Private Sub GetAllFilesEx(foldername As String, _
filespec As String, _
recurse As Boolean, _
ByRef result As Collection)
DoEvents
Dim filename As String, _
fullname As String, _
folder As Variant, _
foldersAs New Collection
If recurse Then
''get any folders
filename = Dir$(foldername & "\*.*", vbDirectory)
Do While filename""
If filename = "." Then GoTo Iterate
If filename = ".." Then GoTo Iterate
fullname = foldername & "\" & filename
If GetAttr(fullname) And vbDirectory Then
folders.Add fullname
End If
Iterate:
filename = Dir$
Loop
End If
''get the files
filename = Dir$(foldername & "\" & filespec, vbHidden)
Do While filename""
fullname = foldername & "\" & filename
result.Add fullname
filename = Dir$
Loop
For Each folder In folders
Call GetAllFilesEx(CStr(folder), filespec, recurse, result)
Next folder
End Sub
编辑：修复了拼写错误。 谢谢，我看看我能不能做到
我不时发布以下模块。它使用api调用，因此速度稍快，只允许搜索某些FileNaName扩展，并在模块末尾包含一个子例程，每次找到指定文件时都会调用该子例程，因此您可以执行诸如打开*之类的操作。dwg，打印a*。txt等
Option Explicit
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" _
Alias "PathMatchSpecW" (ByVal pszFileParam As Long, _
ByVal pszSpec As Long) As Long
Dim sFileExt As String
Dim sFileRoot As String
Public Sub FindAllFiles(FileType As String, StartPath As String)
' recursively searches a passed path for files of a given type
' FileType: a wildcard string of the file extension, ie; "*.dwg" or "*.xls"
' calls "DoSomethingWithFile" subroutine to execute your own code on each found file
sFileRoot = QualifyPath(StartPath) 'start path
sFileExt = FileType 'file type of interest
Call SearchForFiles(sFileRoot)
End Sub
Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
If hFileINVALID_HANDLE_VALUE Then
Do
'if a folder, and recurse specified, call method again
If (WFD.dwFileAttributes And vbDirectory) Then
If Asc(WFD.cFileName)vbDot Then
SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
End If
Else
'must be a file..
If MatchSpec(WFD.cFileName, sFileExt) Then
DoSomethingWithFile sRoot & TrimNull(WFD.cFileName)
End If 'If MatchSpec
End If 'If WFD.dwFileAttributes
Loop While FindNextFile(hFile, WFD)
End If 'If hFile
Call FindClose(hFile)
End Sub
Private Function QualifyPath(sPath As String) As String
' formats passed path string to be used in recursive API search
If Right$(sPath, 1)vbBackslash Then
QualifyPath = sPath & vbBackslash
Else
QualifyPath = sPath
End If
End Function
Private Function TrimNull(startstr As String) As String
' trims NULL char (ascii 0) from strings returned by API calls
TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function
Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
' uses API version of the "LIKE" command
MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec))
End Function
Private Sub DoSomethingWithFile(FoundFileName As String)
' use this routine to do something with each file found
' we'll do nothing but print out the filename found
Dim FoundName As String: FoundName = FoundFileName
Debug.Print FoundName
End Sub
页:
[1]