1 1 1 1 1 1 1 1 1 1 Rating 0.00 (0 Votes)

Problemstellung:

Wie man Dateien in eine MS-Access DB einlesen kann hatte ich schon in
2 verschiedenen Lösungen gezeigt.
 

Jetzt kam aber die Frage auf wie man die Suchroutine dahin gehend ändern kann, dass nur
bis zu einer bestimmten Ordnertiefe suchen kann?
Die Lösung dafür möchte ich hier vorstellen.

Voraussetzungen:
Das Bsp ist ab A00 lauffähig.

Funktionsweise:
In der Bsp-DB befinden sich ein Klassenmodul und 2 Module.
Auf die Erklärung der 2 Module verzichte ich, denn diese dürften selbst erklärend sein.
Kernstück ist das Klassenmodul "cls_ListFiles". Damit wird die Dateistruktur in eine Collection eingelesen.

Public Col_File As Collection

Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
                          Optional bIncludeSubfolders As Boolean)
On Error GoTo Err_Handler

    Dim colDirList As New Collection
    Dim temp_col As New Collection
    Dim varItem As Variant

    Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)

    For Each varItem In colDirList
        temp_col.Add varItem
    Next
    Set Col_File = temp_col

Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Exit_Handler
End Function

Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
                         bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colDirList.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        For Each vFolderName In colFolders
            Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
End Function
 
Diese Klasse wird dann in der Sub "ReadFolder" im Formular aufgerufen.
Die Sub erwartet 4 Parameter:
 
1. strFolder = Sartverzeichnis
2. strFilter = den Dateifilter
3. bSubfolder = mit oder ohne Unterverzeichnisse (Optional, Standardwert = Falsch)
4. iDepth = die Ordnertiefe (Optional, Standardwert = 0, alle Unterverzeichnisse)
 
Hinweis:
Ist bSubfolder=False wird der Parameter iDepth ignoriert.

Dim cLFs As New cls_ListFiles

Private Sub ReadFolder(strFolder As String, strFilter As String, Optional bSubfolder As Boolean = False, _
                       Optional iDepth As Integer = 0)
    
    Dim x
    Dim i As Long, nCount As Long
    Dim rs As DAO.Recordset, db As DAO.Database
    Dim tSplitPath As SplitPath
    Dim iLen As Integer, sTemp As String, iCountSign As Integer

    On Error GoTo Folder_Error
    
    Set db = CurrentDb
    nCount = 0
    'Klasse zum Einlesen der Dateien aufrufen
    x = cLFs.ListFiles(strFolder, strFilter, bSubfolder)
    ' Anzahl der gefunden Dateien anzeigen
    If iDepth = 0 Then Me.lbl_CountFiles.Caption = cLFs.Col_File.Count _
                & " Dateien nach den Kriterien gefunden"
    
    Set rs = db.OpenRecordset("tbl_Files", dbOpenDynaset)
    DoCmd.Echo False, "Bitte warten..., die Tabelle 'Files' wird mit Daten gefüllt"
    
    'Länge des Startverzeichnisses ermitteln
    iLen = Len(strFolder)
    For i = 1 To cLFs.Col_File.Count
        If iDepth = 0 Then
        'Keine Beschränkung der Ordnertiefe
            rs.AddNew
            rs("Datei") = cLFs.Col_File(i)
            rs("Dateigrösse") = FileLen(cLFs.Col_File(i))
            rs("Dateidatum") = FileDateTime(cLFs.Col_File(i))
            tSplitPath = fileSplit(cLFs.Col_File(i))
            rs("Pathname") = tSplitPath.sDrive & tSplitPath.sPath
            rs("Filename") = tSplitPath.sFile
            rs.Update
            DoEvents
        Else
            '*******************************************
            'Prüfen der erreichten Ordnertiefe
            sTemp = Mid(cLFs.Col_File(i), iLen + 1)
            iCountSign = CountSign(sTemp, "\")
            '*******************************************
            If iCountSign <= iDepth Then
            'Vergleich Soll und IST Ordertiefe
                rs.AddNew
                rs("Datei") = cLFs.Col_File(i)
                rs("Dateigrösse") = FileLen(cLFs.Col_File(i))
                rs("Dateidatum") = FileDateTime(cLFs.Col_File(i))
                tSplitPath = fileSplit(cLFs.Col_File(i))
                rs("Pathname") = tSplitPath.sDrive & tSplitPath.sPath
                rs("Filename") = tSplitPath.sFile
                rs.Update
                'Anzahl der Dateien
                nCount = nCount + 1
                DoEvents
            End If
        End If
    Next i

    ' Anzahl der gefunden Dateien anzeigen
    If iDepth <> 0 Then Me.lbl_CountFiles.Caption = nCount & " Dateien nach den Kriterien gefunden"
    DoCmd.Echo True
    rs.Close
    db.Close
    
    On Error GoTo 0
    Exit Sub

Folder_Error:
    Resume Next
End Sub
Call ReadFolder("E:\Eigene Dateien\Access", "*.mdb", True, 2)
Hier würden alle MDB-Dateien aus dem Verzeichnis "E:\Eigene Dateien\Access" mit Unterverzeichnissen bis 2 Ebenen unter dem Startverzeichnis eingelesen.

Dateien:

Dateien mit Angabe der Ordnertiefe in eine MS-Access Datenbank

ab A00

Die RAR-Datei enthält eine Version ab A2000
Datum 05.02.2018
Dateigröße 23.68 KB
Download 706

Ähnliche Artikel

Kommentar schreiben

Sicherheitscode
Aktualisieren

Login Form

Neueste Artikel

SQL zu VBA Konverter
26. Oktober 2018
Problemstellung: Gibt es eine Möglichkeit SQL-Code einer Abfrage so zu konvertieren das der Code in VBA genutzt werden kann? Lösung: Bis Access 2010 gibt das Tool "SmartTools SQL aus Abfragen 3.0"...
1.png2.png1.png2.png7.png5.png5.png
Heute55
Gestern105
Diese Woche263
Dieser Monat1555
Total1212755

  • IP: 52.55.177.115
  • Browser: Unknown
  • Version:
  • OS: Unknown

Online

3
Online

19. Dezember 2018

Letzte Kommentare

  • Trusted Locations Manager

    Tommy Admin 13.07.2018 13:06
    RE: Trusted Locations Manager
    Hallo Matthias, aus Ermangelung einer 64bit Version kann ich das leider nicht prüfen. Tut mir leid. Gruss ...

    Weiterlesen...

     
  • Trusted Locations Manager

    Matthias 13.07.2018 06:48
    Funktioniert nicht
    Habe gerade den TL-Manager installiert. Nach dem Start sagt er mir, dass es kein Office erkennen ...

    Weiterlesen...