Dir und Unterverzeichnisse

hallo j,
oder du nimmst das

Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
    (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const MAX_PATH = 260
Declare Function FileTimeToSystemTime Lib "kernel32" _
    (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Type SYSTEMTIME
         wYear As Integer
         wMonth As Integer
         wDayOfWeek As Integer
         wDay As Integer
         wHour As Integer
         wMinute As Integer
         wSecond As Integer
         wMilliseconds As Integer
End Type
Type FILETIME
         dwLowDateTime As Long
         dwHighDateTime As Long
End Type
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
Type Dateistruktur
     Datei As String
     MSDOSName As String
     Pfad As String
     KompletterPfad As String
     Erstellungsdatum As String
     LetzterZugriff As String
     LetzteAnderung As String
     Groesse As Long
End Type
Dim Dateiliste() As Dateistruktur

Sub DateilisteErstellen()
ReDim Dateiliste(1000)
Dim Zahler As Long
Dim Pfad As String
Dim AnzahlDateien As Long
Dim Datenblock(1 To 7)
     Pfad = InputBox("Bitte Pfad eingeben:", , "c:")
     If Right(Pfad, 1) = "\" Then Pfad = Left(Pfad, Len(Pfad) - 1)
     AnzahlDateien = DurchlaufePfad(Pfad, 1)
     For Zahler = 1 To AnzahlDateien
         Datenblock(1) = Dateiliste(Zahler).Datei
         Datenblock(2) = Dateiliste(Zahler).MSDOSName
         Datenblock(3) = Dateiliste(Zahler).KompletterPfad
         Datenblock(4) = Dateiliste(Zahler).Erstellungsdatum
         Datenblock(5) = Dateiliste(Zahler).LetzteAnderung
         Datenblock(6) = Dateiliste(Zahler).LetzterZugriff
         Datenblock(7) = Dateiliste(Zahler).Groesse
         Range(Cells(Zahler + 1, 1), Cells(Zahler + 1, 7)) = _
          Datenblock
     Next
     Columns.AutoFit
End Sub

Function DurchlaufePfad(ByVal Pfadname As String, _
    ByVal Dateiindex As Long) As Long
Dim Suchhandle As Long
Dim Ruckgabewert1 As Long
Dim dummy
Dim Suchkriterium As String
Dim Zeile As Long
Dim Erstellungsdatum As Date
Dim Datumszwischenspeicher As SYSTEMTIME
Dim Filedaten As WIN32_FIND_DATA
Pfadname = Trim(Pfadname)
If Right$(Pfadname, 1) = "\" Then
     Suchkriterium = Pfadname & "*"
Else
     Suchkriterium = Pfadname & "\*"
End If
Zeile = Dateiindex
Filedaten.cAlternate = String(14, Chr(0))
Filedaten.cFileName = String(260, Chr(0))
Suchhandle = FindFirstFile(Suchkriterium, Filedaten)
Ruckgabewert1 = Suchhandle
Do While Ruckgabewert1 <> 0
     Filedaten.cFileName = Left(Filedaten.cFileName, InStr _
       (1, Filedaten.cFileName, Chr(0)) - 1)
     Filedaten.cAlternate = Left(Filedaten.cAlternate, InStr _
       (1, Filedaten.cAlternate, Chr(0)) - 1)
     If Trim(Filedaten.cFileName) <> "." And Trim _
       (Filedaten.cFileName) <> ".." Then

         If Filedaten.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then
             Zeile = DurchlaufePfad((Pfadname & "\" & _
                Trim(Filedaten.cFileName)), Zeile)
         End If

         If Zeile = UBound(Dateiliste) Then ReDim _
          Preserve Dateiliste(Zeile + 100)
         Dateiliste(Zeile).Datei = Trim(Filedaten.cFileName)
         Dateiliste(Zeile).MSDOSName = Trim(Filedaten.cAlternate)
         Dateiliste(Zeile).Pfad = Pfadname
         Dateiliste(Zeile).KompletterPfad = Pfadname & "\" & _
          Dateiliste(Zeile).Datei
         dummy = FileTimeToSystemTime(Filedaten.ftCreationTime, _
          Datumszwischenspeicher)
         Dateiliste(Zeile).Erstellungsdatum = DateSerial _
          (Datumszwischenspeicher.wYear, Datumszwischenspeicher.wMonth, _
          Datumszwischenspeicher.wDay) _
             + TimeSerial(Datumszwischenspeicher.wHour, _
             Datumszwischenspeicher.wMinute, Datumszwischenspeicher.wSecond)
         dummy = FileTimeToSystemTime(Filedaten.ftLastAccessTime, _
          Datumszwischenspeicher)
         Dateiliste(Zeile).LetzterZugriff = DateSerial( _
          Datumszwischenspeicher.wYear, Datumszwischenspeicher.wMonth, _
          Datumszwischenspeicher.wDay) _
          + TimeSerial(Datumszwischenspeicher.wHour, _
          Datumszwischenspeicher.wMinute, Datumszwischenspeicher.wSecond)
         dummy = FileTimeToSystemTime(Filedaten.ftLastWriteTime, _
          Datumszwischenspeicher)
         Dateiliste(Zeile).LetzteAnderung = _
          DateSerial(Datumszwischenspeicher.wYear, _
          Datumszwischenspeicher.wMonth, Datumszwischenspeicher.wDay) _
          + TimeSerial(Datumszwischenspeicher.wHour, _
          Datumszwischenspeicher.wMinute, Datumszwischenspeicher.wSecond)
         Dateiliste(Zeile).Groesse = Filedaten.nFileSizeLow
         Zeile = Zeile + 1
     End If
     Filedaten.cAlternate = String(14, Chr(0))
     Filedaten.cFileName = String(260, Chr(0))
     Ruckgabewert1 = FindNextFile(Suchhandle, Filedaten)
Loop
DurchlaufePfad = Zeile
dummy = FindClose(Suchhandle)
End Function

Code eingefügt mit Syntaxhighlighter 2.5

gruss andre

Sub InhaltAnzeigen() Pfad = Range("A11").Value Datei = Dir(Pfad, vbDirectory) 'Ersten Eintrag abrufen. Range("A13:A1000").ClearContents Range("A13").Select Do While Datei <> "" If Datei <> "." And Datei <> ".." Then ActiveCell.Value = Datei ActiveCell.Offset(1, 0).Select End If Datei = Dir 'Nächsten Eintrag abrufen. Loop End Sub

Sub InhaltAnzeigen() Pfad1 = Range("A11").Value Datei1 = Dir(Pfad1, vbDirectory) 'Ersten Eintrag abrufen. Range("A13:A1000").ClearContents Range("A13").Select Do While Datei1 <> "" If Datei1 <> "." And Datei1 <> ".." Then If (GetAttr(Pfad1 & Datei1) And vbDirectory) = vbDirectory Then Pfad2 = Pfad1 & Datei1 MsgBox Pfad2 Datei2 = Dir(Pfad2, vbDirectory) Do While Datei2 <> "" If Datei2 <> "." And Datei2 <> ".." Then ActiveCell.Value = " " & Datei2 ActiveCell.Offset(1, 0).Select End If Datei2 = Dir Loop Else ActiveCell.Value = Datei1 ActiveCell.Offset(1, 0).Select End If End If Datei1 = Dir 'Nächsten Eintrag abrufen. Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
probier mal das aus.
Spezielle für dich interessant ist eigentlich die Anweisung
With Application.FileSearch
Damit kannst du das machen was du willst. In dem Beispiel wird eine Listbox in einer Userform mit allen Dateien, auf die das Suchkriterium zutrifft, gefüllt .

Sub Find_Files_with_Textfragment()
Dim i As Long
Dim gefFile As String, dname As String
Dim Suchpfad As String, Suchbegriff As String, Dateiform As String
Dim oldStatus As Variant, myMatch As Boolean, msgTxt As String, Qe As Variant
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll:", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Suchbegriff = InputBox("Geben Sie den Text an der in den Dateien gesucht werden soll", "Textfragment", "")
If Suchbegriff = "" Then Exit Sub
msgTxt = "Soll auf exakte Übereinstimmung mit dem Dateinamen gesucht werden ? "
msgTxt = msgTxt & vbCrLf & "Bei ""Nein"" werden als Ergebnis auch Dateien angezeigt,"
msgTxt = msgTxt & vbCrLf & "bei denen nur ein Teil des Namens mit:"" " & Suchbegriff & " "" übereinstimmt !"
Qe = MsgBox(msgTxt, vbQuestion + vbYesNo, "Suchroutine")
If Qe = vbOK Then
    myMatch = True
Else
    myMatch = False
End If
'Bildschirmaktualisier abschalten
Application.ScreenUpdating = True
'Text der Statusbar und alten Status aufnehmen
oldStatus = Application.StatusBar
'Start der Suchroutine
With Application.FileSearch
    .NewSearch
    .LookIn = Suchpfad
    .TextOrProperty = Suchbegriff
    .SearchSubFolders = True
    ' = True wenn der Suchbegriff GENAU übereinstimmen soll
    ' = False wenn nur ein Teil des Dateinamens übereinstimmen soll
    .MatchTextExactly = myMatch
    .FileType = Dateiform
    If .Execute() > 0 Then
        totFiles = .FoundFiles.count
        'Ausgabe in Statusbar
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.count
            gefFile = .FoundFiles(i)
             'In Listbox eintragen mit der AddItem Methode
            Me.ListBox1.AddItem (gefFile)
        Next i
    End If
End With
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

1 Forumthread zu ähnlichem Thema

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dir und Unterverzeichnisse

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

1 Forumthread zu ähnlichem Thema

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread