Option Compare Database
Option Explicit
Private Declare Sub FindClose Lib "kernel32" (ByVal hFindFile As Long)
Private Declare Function FindFirstFileA Lib "kernel32" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFileA Lib "kernel32" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributesA Lib "kernel32" (ByVal lpFileName As String) As Long
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 * 260
cAlternate As String * 14
End Type
Public Function FindFiles(ByVal Path As String, ByRef Files As Collection, Optional ByVal Pattern As String = "*.*", Optional ByVal Attributes As VbFileAttribute = vbNormal, Optional ByVal Recursive As Boolean = True) As Long
Const vbErr_PathNotFound = 76
Const INVALID_VALUE = -1
Dim FileAttr As Long
Dim FileName As String
Dim hFind As Long
Dim WFD As WIN32_FIND_DATA
'Initialisierung:
If Right$(Path, 1) <> "\" Then Path = Path & "\"
If Files Is Nothing Then Set Files = New Collection
Pattern = LCase$(Pattern)
'Suche starten:
hFind = FindFirstFileA(Path & "*", WFD)
If hFind = INVALID_VALUE Then
Err.Raise vbErr_PathNotFound
End If
'Suche fortsetzen:
Do While FindNextFileA(hFind, WFD)
FileName = LeftB$(WFD.cFileName, _
InStrB(WFD.cFileName, vbNullChar))
FileAttr = GetFileAttributesA(Path & FileName)
If FileAttr And vbDirectory Then
'Verzeichnis analysieren:
If Recursive Then
If FileAttr <> INVALID_VALUE And FileName <> "." And FileName <> ".." Then
FindFiles = FindFiles + FindFiles(Path & FileName, Files, Pattern, Attributes)
End If
End If
Else
'Datei analysieren:
If (FileAttr And Attributes) = Attributes Then
If LCase$(FileName) Like Pattern Then
FindFiles = FindFiles + 1
Files.Add Path & FileName
End If
End If
End If
Loop
FindClose hFind
End Function
Private Sub Befehl0_Click()
On Error GoTo 1
'Lokale Variablen und Objekte
Dim rs As ADODB.Recordset
Dim dateien As Collection
Dim i As Long
'Objekte initialisieren
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM bilder;", CurrentProject.Connection, adOpenStatic, adLockPessimistic, -1
If rs.RecordCount > 0 Then
'Wenn schon Datensätze eingetragen worden sind, diese zuerst löschen, um Dupletten zu vermeiden.
rs.MoveFirst
Do While Not rs.EOF
rs.Delete adAffectCurrent
DoEvents
Loop
End If
'Dateimuster (*.jpg) suchen und alle gefundenen Dateien in das Recordset eintragen
If FindFiles("C:", dateien, "*.jpg", vbArchive) Then
For i = 1 To dateien.Count
rs.AddNew
rs!datei = dateien(i)
rs.Update
DoEvents
Next i
MsgBox "Es wurden " & CStr(dateien.Count) & " JPG-Bilder auf Laufwerk C: gefunden.", vbInformation, "Ergebnis"
Else
MsgBox "Keine JPG-Bilder auf Laufwerk C: gefunden.", vbInformation, "Ergebnis"
End If
rs.Close
'Objekte zerstören
Set rs = Nothing
Exit Sub
1 MsgBox "Fehler 1: " & Err.Description
End Sub
