AW: Verzeichnis auslesen
11.04.2014 14:46:43
Tino
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