Dateien suchen (Unterverzeichnisse eingeschlossen) - per Windows API.
Option Explicit
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH As Long = 260&
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
Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20&
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800&
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10&
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2&
Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Const FILE_ATTRIBUTE_READONLY As Long = &H1&
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4&
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100&
Public Function GetFiles(ByVal Path As String, ByVal FileExtensionFilter As String, ByRef Files As VBA.Collection) As Long
If Right$(Path, 1) <> "\" Then Path = Path & "\"
If FileExtensionFilter = "" Then Exit Function
If Files Is Nothing Then Set Files = New VBA.Collection
Dim fd As WIN32_FIND_DATA
Dim strFile As String
Dim hFile As LongPtr
hFile = FindFirstFile(Path & "*.*", fd)
If hFile = 0 Then Exit Function
Do
strFile = Left$(fd.cFileName, InStr(fd.cFileName, vbNullChar) - 1)
If (fd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
'-> Verzeichnis
If strFile <> "." And strFile <> ".." Then
'-> rekursiv weiter suchen...
Call GetFiles(Path & strFile, FileExtensionFilter, Files)
End If
Else
'-> Datei
If strFile Like FileExtensionFilter Then
Call Files.Add(Path & strFile)
End If
End If
Loop While FindNextFile(hFile, fd)
Call FindClose(hFile)
GetFiles = Files.Count
End Function
Beispielaufruf:
Public Sub Test()
Dim colFiles As VBA.Collection
Dim vntFile As Variant
Set colFiles = New VBA.Collection
If GetFiles("X:\RootFolder\SubFolder\", "*.sxw", colFiles) > 0 Then
' For i = 1 To colFiles.Count
For Each vntFile In colFiles
Debug.Print vntFile
Next
Debug.Print "files found:"; colFiles.Count
Call MsgBox(colFiles.Count & " Dateien gefunden.", vbInformation)
Else
Call MsgBox("Nix gefunden.", vbInformation)
End If
End Sub
|