TheSwamp
Code Red => VB(A) => Topic started by: David Hall on January 02, 2009, 04:08:41 PM
-
I have been looking around, and cant find a way to seach for a file, that includes the subdirectories. Excel has a .FileSearch method, but that doesn't help
Any ideas?
-
Without checking each directory for other directories, then checking them, I'm not sure.
-
Best? Certainly not, I wrote this about a hundred years ago (don't laugh). Abuse as you see fit.
Option Explicit
[color=red]Public[/color] Sub Test ( )
Dim foldername As String, _
filespec As String, _
var As Variant
foldername = "c:\windows\temp"
[color=green] '' you could use this to reduce the initial scan results[/color]
filespec = "*.*"
[color=green] '' 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[/color]
For Each var In GetAllFiles(foldername, filespec, True)
Debug.Print var
[color=green] '' do your final file matching code here if filespec doesn't nail it[/color]
Next var
End Sub
[color=blue]Public[/color] 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
[color=red]Private[/color] 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, _
folders As New Collection
If recurse Then
[color=green] '' get any folders[/color]
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
[color=green] '' get the files[/color]
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
Edit: fixed a typo.
-
thanks, I will see if I can make that work
-
I have been looking around, and cant find a way to seach for a file, that includes the subdirectories. Excel has a .FileSearch method, but that doesn't help
Any ideas?
I post the following module now and then. It uses api calls, so its a little faster, allows searching for only certain filenanme extensions, and includes a subroutine at the end of the module that gets called every time one of your specified files is found so you can do things such as OPEN a *.dwg, PRINT a *.txt, etc
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 hFile <> INVALID_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