Tipp 0328 Rekursives Suchen von Dateien (FSO)
Autor/Einsender:
Datum:
  Jürgen Beil
20.04.2003
Entwicklungsumgebung:   VB 6
Um eine Dateisuche zu verwirklichen, benötigt man eine Funktion, die nicht nur das aktuelle Verzeichnis, sondern auch alle Unterverzeichnisse durchsucht. Dazu kann man sich verschiedener Methoden bedienen, z.B. mittels API-Funktionen, dem FileSystemObject oder auch der Visual Basic Dir$-Funktion.
Dieses Beispiel zeigt wie mit Hilfe des FileSystemObjects (FSO) eine rekursive Suche verwirklicht werden kann, die alle Dateien mit dem übergebenen Suchmuster auflistet. Da jedoch das FileSystemObject selbst keine Möglichkeit bietet, Platzhalter im Suchbegriff zu verwenden, wurde dazu die Dir$-Funktion implementiert.
 
Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private m_lngDirCount As Long
Private m_lngFileCount As Long
Private m_astrFiles() As String
Private m_blnCancel As Boolean

Private m_objFSO As Scripting.FileSystemObject

Private Sub Form_Load()
  lblMsg.Caption = ""
  lstFiles.Clear
End Sub

Private Sub cmdSuchen_Click()
  Dim tStart As Single
  Dim tEnd As Single
  Dim tDiff As String

  Dim i As Long
  Dim strMsg As String

  lstFiles.Visible = False
  lstFiles.Clear

  m_blnCancel = False
  m_lngDirCount = 0
  m_lngFileCount = 0

  ReDim m_astrFiles(0 To 100)

  tStart = GetTickCount()

  Set m_objFSO = New Scripting.FileSystemObject
  FindFiles Dir1.Path, txtSearchString.Text
  Set m_objFSO = Nothing

  If m_lngFileCount > 0 Then
    lblMsg.Caption = "Bitte warten... " & _
          "Die Dateien werden zur ListBox hinzugefügt..."
    DoEvents
    For i = 0 To m_lngFileCount - 1
      lstFiles.AddItem m_astrFiles(i)
    Next
  End If

  tEnd = GetTickCount()
  tDiff = Format$((tEnd - tStart) / 1000, "##0.00") & "  sec."

  strMsg = m_lngFileCount & " Dateien gefunden / " & _
           m_lngDirCount & " Ordner durchsucht."

  If m_blnCancel Then
    lblMsg.Caption = _
        "Die Suche nach Datei(en) wurde abgebrochen!  " & strMsg
  Else
    lblMsg.Caption = strMsg & " (Dauer: " & tDiff & ")"
  End If

  lstFiles.Visible = True
End Sub

Private Sub cmdAbbrechen_Click()
  m_blnCancel = True
End Sub

Private Sub FindFiles(ByVal vsFolderPath As String, _
      ByVal vsSearch As String)
  Dim objFolder As Scripting.Folder
  Dim objFolderLoop As Scripting.Folder

  Dim strFileName As String
  
  If m_blnCancel = True Then GoTo byebye

  lblMsg.Caption = vsFolderPath
  DoEvents

  On Error GoTo err_Handler
  
  Set objFolder = m_objFSO.GetFolder(vsFolderPath)

  strFileName = Dir$(m_objFSO.BuildPath(objFolder.Path, vsSearch), _
                  vbNormal Or vbHidden Or vbSystem Or vbReadOnly)

  Do While Len(strFileName) > 0
    m_astrFiles(m_lngFileCount) = m_objFSO.BuildPath( _
                        objFolder.Path, strFileName)
    m_lngFileCount = m_lngFileCount + 1
    If (m_lngFileCount Mod 100) = 0 Then
      ReDim Preserve m_astrFiles(m_lngFileCount + 100)
    End If
    strFileName = Dir$()
  Loop

  m_lngDirCount = m_lngDirCount + 1

  If objFolder.SubFolders.Count > 0 Then
    For Each objFolderLoop In objFolder.SubFolders
      FindFiles objFolderLoop.Path, vsSearch
    Next objFolderLoop
  End If

byebye:
  Set objFolder = Nothing
  On Error GoTo 0
  Exit Sub

err_Handler:
  strFileName = ""
  Resume Next
End Sub
 
Weitere Links zum Thema
Rekursives Suchen von Dateien (API)
Hinweis
Um dieses Beispiel ausführen zu können, muss ein Verweis auf die  Microsoft Scripting Runtime (SCRRUN.DLL) gesetzt werden.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5,7 kB) Downloads bisher: [ 2507 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 17. September 2011