This has both a method based on Dir and one on the API:
Option Explicit
Private Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenW" _
(ByVal lpString 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 GetFileAttributes _
Lib "kernel32" _
Alias "GetFileAttributesA" _
(ByVal lpFileName As String) _
As Long
Private Declare Function FindClose _
Lib "kernel32" (ByVal hFindFile As Long) _
As Long
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
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
Function TrimNull(strString As String) As String
TrimNull = Left$(strString, lstrlen(StrPtr(strString)))
End Function
Function RecursiveFindFiles(strPath As String, _
strSearch As String, _
Optional bSubFolders As Boolean = True, _
Optional bSheet As Boolean = False, _
Optional lFileCount As Long = 0, _
Optional lDirCount As Long = 0, _
Optional lSkipCount As Long = 0) As Variant
'adapted from the MS example:
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476
'---------------------------------------------------------------
'will list all the files in the supplied folder and it's
'subfolders that fit the strSearch criteria
'lFileCount, lDirCount and lSkipCount will always have to start as 0
'-------------------------------------------------------------------
Dim strFileName As String 'Walking strFileName variable.
Dim strDirName As String 'SubDirectory Name.
Dim collDirNames As Collection 'Buffer for directory name entries.
Dim nDir As Long 'Number of directories in this strPath.
Dim i As Long 'For-loop counter.
Dim n As Long
Dim arrFiles
Static strStartDirName As String
Static strpathOld As String
On Error GoTo sysFileERR
If lFileCount = 0 Then
Static collFiles As Collection
Set collFiles = New Collection
Application.Cursor = xlWait
End If
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If lFileCount = 0 And lDirCount = 0 Then
strStartDirName = strPath
End If
'search for subdirectories
'-------------------------
nDir = 0
Set collDirNames = New Collection
strDirName = Dir(strPath, _
vbDirectory Or _
vbHidden Or _
vbArchive Or _
vbReadOnly Or _
vbSystem) 'Even if hidden, and so on.
Do While Len(strDirName) > 0
'ignore the current and encompassing directories
'-----------------------------------------------
If (strDirName <> ".") And (strDirName <> "..") Then
'check for directory with bitwise comparison
'-------------------------------------------
If GetAttr(strPath & strDirName) And vbDirectory Then
collDirNames.Add strDirName
lDirCount = lDirCount + 1
nDir = nDir + 1
DoEvents
End If 'directories.
sysFileERRCont1:
End If
strDirName = Dir() 'Get next subdirectory
DoEvents
Loop
'Search through this directory
'-----------------------------
strFileName = Dir(strPath & strSearch, _
vbNormal Or _
vbHidden Or _
vbSystem Or _
vbReadOnly Or _
vbArchive)
While Len(strFileName) <> 0
'dump file in sheet
'------------------
'If bSheet Then
'If lFileCount < 65536 Then
'Cells(lFileCount + 1, 1) = strPath & strFileName
'End If
'End If
lFileCount = lFileCount + 1
collFiles.Add strPath & strFileName
'If strPath <> strpathOld Then
'Application.StatusBar = " " & lFileCount & _
" " & strSearch & " files found. " & _
"Now searching " & strPath
'End If
'strpathOld = strPath
strFileName = Dir() 'Get next file
DoEvents
Wend
If bSubFolders Then
'If there are sub-directories..
'------------------------------
If nDir > 0 Then
'Recursively walk into them
'--------------------------
For i = 1 To nDir
RecursiveFindFiles strPath & collDirNames(i) & "\", _
strSearch, _
bSubFolders, _
bSheet, _
lFileCount, _
lDirCount, _
lSkipCount
DoEvents
Next
End If 'If nDir > 0
'only bare main folder left, so get out
'--------------------------------------
If strPath = strStartDirName Then
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If
Else 'If bSubFolders
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If 'If bSubFolders
Exit Function
sysFileERR:
lSkipCount = lSkipCount + 1
Resume sysFileERRCont1
End Function
Sub FindFilesAPI(strPath As String, _
strSearch As String, _
bSubDirs As Boolean, _
lFileCount As Long, _
lDirCount As Long, _
collFiles As Collection)
Dim i As Long
Dim strFileName As String 'Walking strFileName variable...
Dim strDirName As String 'SubDirectory Name
'Buffer for directory name entries
Dim collDirNames As Collection
Dim lDir As Long 'Number of directories in this path
Dim hSearch As Long 'Search Handle
Dim WFD As WIN32_FIND_DATA
Dim iCont As Integer
If lFileCount = 0 Then
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
End If
'Search for subdirectories
lDir = 0
Set collDirNames = New Collection
iCont = True
hSearch = FindFirstFile(strPath & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While iCont
strDirName = TrimNull(WFD.cFileName)
'Ignore the current and encompassing directories
If (strDirName <> ".") And (strDirName <> "..") Then
'Check for directory with bitwise comparison
If GetFileAttributes(strPath & strDirName) And _
FILE_ATTRIBUTE_DIRECTORY Then
collDirNames.Add strDirName
lDir = lDir + 1
lDirCount = lDirCount + 1
End If
End If
'Get next subdirectory
iCont = FindNextFile(hSearch, WFD)
Loop
iCont = FindClose(hSearch)
End If
'Walk through this directory
hSearch = FindFirstFile(strPath & strSearch, WFD)
iCont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While iCont
strFileName = TrimNull(WFD.cFileName)
If (strFileName <> ".") And (strFileName <> "..") And _
Len(strFileName) > 0 Then
'---------------------------------------------
'maybe a dictionary or a string will be faster
'not worth it though as this only a tiny part
'of the total time
'---------------------------------------------
collFiles.Add strPath & strFileName
lFileCount = lFileCount + 1
End If
iCont = FindNextFile(hSearch, WFD) 'Get next file
Wend
iCont = FindClose(hSearch)
End If
If bSubDirs = False Then
Exit Sub
End If
'If there are sub-directories...
If lDir > 0 Then
'Recursively walk into them...
For i = 1 To lDir
FindFilesAPI strPath & _
collDirNames(i) & _
"\", _
strSearch, _
bSubDirs, _
lFileCount, _
lDirCount, _
collFiles
Next i
End If
End Sub
RBS
"NickHK" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> May this page is more applicable to the .FileSerach aspect :
> http://vbnet.mvps.org/code/fileapi/r...es_minimal.htm
>
> NickHK
>
> "RB Smissaert" <(E-Mail Removed)> wrote in message
> news:OJX9$(E-Mail Removed)...
>> Have a go with this code:
>>
>>
>> Option Explicit
>> Public Declare Function FindWindow _
>> Lib "user32" Alias "FindWindowA" _
>> (ByVal lpClassName As String, _
>> ByVal lpWindowName As String) As Long
>>
>> Private Declare Function lstrlen Lib "kernel32" _
>> Alias "lstrlenW" (ByVal lpString As
>> Long)
>> As Long
>>
>> Private Declare Function SetCurrentDirectoryA _
> -------------------- CUT ---------------------------
>
>
Similar Threads
