Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema ListBox
BildScreenshot zu ListBox ListBox-Seite mit Beispielarbeitsmappe aufrufen

Verzeichnis auslesen

Betrifft: Verzeichnis auslesen von: MB
Geschrieben am: 11.04.2014 13:54:25

Hallo zusammen,

ich möchte alle Dateien eines Verzeichnisses mit Speicherdatum auslesen und in einer Tabelle auflisten. Kann mir da jemand behilflich sein?

Besten Dank im Voraus!

Freundliche Grüße

Michael

  

Betrifft: AW: Verzeichnis auslesen von: Tino
Geschrieben am: 11.04.2014 14:46:43

Hallo,
hier mal eine Variante zum testen.

kommt als Code in Modul1

Option Explicit 
 
Public Sub Start() 
Dim strFolder$, ArFileFilter() 
Dim nCount&, lngFilecount& 
Dim ArrayData() 
   
With Tabelle1 'Tabelle angeben 
    'Tabelle leer machen für neue Daten 
    .Range("A2", .Cells(.Rows.Count, 3)).Clear 
    'Filter für die Suche *.* = alle 
    ArFileFilter = Array("*.pdf", "*.jpg", "*.msg", "*.xls") 
      
    strFolder = OrdnerAuswahl("G:\") 'Ordner wählen 
     
    If strFolder <> "" Then 
        strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\") 
        FindFiles ArrayData, strFolder, lngFilecount, ArFileFilter, True 'mit Unterordner = True sonst False 
    End If 
      
    If lngFilecount > 0 Then 
        With .Range("A2").Resize(lngFilecount, 3) 
            .FormulaR1C1 = Application.Transpose(ArrayData) 
            .EntireColumn.AutoFit 
        End With 
    End If 
End With 
Erase ArrayData 
End Sub 
kommt als Code in Modul2
Option Explicit 
Option Private Module 
 
'Teile des Originalcode von Nepumuk. *********************************************************** 
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 
Private Declare Function FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long) As Long 
 
Private Const INVALID_HANDLE_VALUE = -1& 
Private Const MAX_PATH = 260& 
 
Private Type FILETIME 
    dwLowDateTime As Long 
    dwHighDateTime As Long 
End Type 
 
Private Enum FILE_ATTRIBUTE 
    FILE_ATTRIBUTE_READONLY = &H1 
    FILE_ATTRIBUTE_HIDDEN = &H2 
    FILE_ATTRIBUTE_SYSTEM = &H4 
    FILE_ATTRIBUTE_DIRECTORY = &H10 
    FILE_ATTRIBUTE_ARCHIVE = &H20 
    FILE_ATTRIBUTE_NORMAL = &H80 
    FILE_ATTRIBUTE_TEMPORARY = &H100 
End Enum 
 
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 * MAX_PATH 
    cAlternate As String * 14 
End Type 
Dim FSO As Object 
'Ordner Dialog 
Public Function OrdnerAuswahl(Optional ByVal sPath As String = "C:\") 
Dim strOrdner As String 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .InitialFileName = sPath 
    .Title = "Ordnerauswahl" 
    .ButtonName = "Auswahl..." 
    .InitialView = msoFileDialogViewList 
    If .Show = -1 Then 
        strOrdner = .SelectedItems(1) 
        If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\" 
    Else 
        strOrdner = "" 
    End If 
End With 
OrdnerAuswahl = strOrdner 
End Function 
 
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
        ByRef lngFilecount As Long, ArFileFilter, Optional SubFolder As Boolean = True) 
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String 
 
    Set FSO = CreateObject("Scripting.FileSystemObject") 
 
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD) 
 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        GetFilesInFolder ArrayData, strFolderPath, lngFilecount, ArFileFilter 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then 
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
                If SubFolder = False Then Exit Sub 'ohne Unterordner 
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles ArrayData, strFolderPath & strDirName & "\", lngFilecount, ArFileFilter 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
    Set FSO = Nothing 
End Sub 
 
Sub GetFilesInFolder(ArrayData(), ByVal strFolderPath As String, _
        ByRef lngFilecount As Long, ArFileFilter) 
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String 
Dim FileFilter 
 
For Each FileFilter In ArFileFilter 
    lngSearch = FindFirstFile(strFolderPath & FileFilter, WFD) 
    If lngSearch <> INVALID_HANDLE_VALUE Then 
        Do 
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then 
                lngFilecount = lngFilecount + 1 
                strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1) 
 
                Redim Preserve ArrayData(1 To 3, 1 To lngFilecount) 
                ArrayData(1, lngFilecount) = strFolderPath & strFileName 'Name 
                ArrayData(2, lngFilecount) = FSO.getFile(ArrayData(1, lngFilecount)).DateLastModified  'letzte Änderung 
                ArrayData(3, lngFilecount) = "=HYPERLINK(""" & strFolderPath & strFileName & """,""" & strFileName & """)" 'link 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
Next 
End Sub 
 
Gruß Tino


  

Betrifft: owT: Super Danke schön - genau was ich suchte! von: MB
Geschrieben am: 11.04.2014 15:27:22




 

Beiträge aus den Excel-Beispielen zum Thema "Verzeichnis auslesen"