AW: Pfadübernahme
05.06.2023 21:03:09
Ulf
Versuch's mal mit
Option Explicit
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long ' Dateiattribute
ftCreationTime As FILETIME ' Erstellungsdatum
ftLastAccessTime As FILETIME ' Letzter Zugriff
ftLastWriteTime As FILETIME ' Letzte Speicherung
nFileSizeHigh As Long ' Größe (Hi)
nFileSizeLow As Long ' Größe (Lo)
dwReserved0 As Long ' bedeutungslos
dwReserved1 As Long ' bedeutungslos
cFileName As String * MAX_PATH ' Dateiname
cAlternate As String * 14 ' 8.3-Dateiname
End Type
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
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Sub listeUnterordner()
Dim lngAnzahl As Long
Dim strSuchenAb As String
Dim varRet As Variant
Dim arrDateien()
strSuchenAb = "c:\users\hg\documents\*"
varRet = dateiSuche(strSuchenAb, True)
If IsArray(varRet) Then
arrDateien = varRet
lngAnzahl = UBound(varRet)
'Testausgabe
Dim lngZähler As Long
For lngZähler = 0 To UBound(arrDateien)
Debug.Print lngZähler + 1; arrDateien(lngZähler)
Next lngZähler
End If
End Sub
Public Function dateiSuche(strPath As String, verzeichnisJANEIN As Boolean) As Variant
On Local Error GoTo dateiSucheERR
Dim gDateien()
Dim X As Long
Dim FileHandle As Long
Dim FileData As WIN32_FIND_DATA
Dim fileName As String
X = -1
FileHandle = FindFirstFile(strPath & vbNullChar, FileData)
If FileHandle > INVALID_HANDLE_VALUE Then
Erase gDateien
Do
' Abschließendes vbNullChar des Dateinamens entfernen
fileName = Left$(FileData.cFileName, InStr(FileData.cFileName, vbNullChar) - 1)
' Verzeichnis-Einträge nicht hinzufügen
If verzeichnisJANEIN = True Then
If (FileData.dwFileAttributes And vbDirectory) = vbDirectory Then
X = X + 1
ReDim Preserve gDateien(X)
gDateien(X) = fileName
End If
Else
If (FileData.dwFileAttributes And vbDirectory) = 0 Then
X = X + 1
ReDim Preserve gDateien(X)
gDateien(X) = fileName
End If
End If
Loop Until FindNextFile(FileHandle, FileData) = 0
dateiSuche = gDateien()
Else
dateiSuche = X
End If
FindClose FileHandle
dateiSucheOUT:
Exit Function
dateiSucheERR:
dateiSuche = X
Resume dateiSucheOUT
End Function
Grüsse
Ulf