AW: Bitte in die Datei schauen-nur ein Bild..
29.04.2012 13:35:48
Tino
Hallo,
hier mal eine Variante zum testen.
kommt als Code in Modul1
Option Explicit
Sub Start()
Dim strFolder$, sString$, FileFilter$
Dim nCount As Long, lngFilecount As Long
Dim ArrayData(), ArFileFilter()
With Tabelle1
.UsedRange.EntireRow.Delete
ArFileFilter = Array("*.pdf", "*.jpg", "*.msg", "*.xls") 'Filter für die Suche
strFolder = "D:\" 'Suchordner
If strFolder <> "" Then
strFolder = IIf(Right$(strFolder, 1) = "\", strFolder, strFolder & "\")
'Parameter
'Array, Ordner-Pfad, Counter, Filter, [Subfolder = False], [Änderungsdatum = enuLastModifiedAnyTime]
' alle = enuLastModifiedAnyTime
' Letzter Monat = enuLastModifiedLastMonth
' Letzte Woche = enuLastModifiedLastWeek
' Dieser Monat = enuLastModifiedThisMonth
' Diese Woche = enuLastModifiedThisWeek
' heute = enuLastModifiedToday
' gestern = enuLastModifiedYesterday
FindFiles ArrayData, strFolder, lngFilecount, ArFileFilter, True, enuLastModifiedThisMonth
If lngFilecount > 0 Then Transponieren ArrayData
End If
If lngFilecount > 0 Then
'Daten einfügen ab A1, Zeile 1 = Überschrift
With .Range("A1").Resize(Ubound(ArrayData) + 1, Ubound(ArrayData, 2))
'Überschrift
.Cells(1, 1) = "File"
.Cells(1, 2) = "Erstellt"
.Cells(1, 3) = "Letzte Änderung"
.Cells(1, 4) = "Letzter Zugriff"
.Rows(1).Font.Bold = True
'Daten
.Range(.Rows(2), .Rows(.Rows.Count)).Value = 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 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 FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
Enum LastModified
enuLastModifiedAnyTime
enuLastModifiedLastMonth
enuLastModifiedLastWeek
enuLastModifiedThisMonth
enuLastModifiedThisWeek
enuLastModifiedToday
enuLastModifiedYesterday
End Enum
Dim Fso As Object
Sub FindFiles(ArrayData(), ByVal strFolderPath As String, _
ByRef lngFilecount As Long, ArFileFilter, Optional SubFolder As Boolean = True, Optional ModifiedDate As LastModified = enuLastModifiedAnyTime)
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, ModifiedDate
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, SubFolder, ModifiedDate
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, Optional ModifiedDate As LastModified = -1)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
Dim FileFilter, F1 As Object
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
strFileName = strFolderPath & Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
Set F1 = Fso.GetFile(strFileName)
If CheckModified(F1.DateLastModified, ModifiedDate) Then
lngFilecount = lngFilecount + 1
Redim Preserve ArrayData(1 To 4, 1 To lngFilecount)
ArrayData(1, lngFilecount) = strFileName
ArrayData(2, lngFilecount) = F1.DateCreated
ArrayData(3, lngFilecount) = F1.DateLastModified
ArrayData(4, lngFilecount) = F1.DateLastAccessed
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Next
End Sub
Function CheckModified(ByVal Datum, ModifiedDate As LastModified) As Boolean
Dim tmpDate As Date
Datum = CDate(Fix(Datum))
Select Case ModifiedDate
Case enuLastModifiedAnyTime
CheckModified = True
Case enuLastModifiedLastMonth
CheckModified = (Datum >= DateSerial(Year(Date), Month(Date) - 1, 1)) And (Datum <= DateSerial(Year(Date), Month(Date), 1) - 1)
Case enuLastModifiedLastWeek
tmpDate = Date - (Weekday(Date, 2) - 1) - 7
CheckModified = (Datum >= tmpDate) And (Datum <= tmpDate + 6)
Case enuLastModifiedThisMonth
CheckModified = (Datum >= DateSerial(Year(Date), Month(Date), 1)) And (Datum <= DateSerial(Year(Date), Month(Date) + 1, 1) - 1)
Case enuLastModifiedThisWeek
tmpDate = Date - (Weekday(Date, 2) - 1)
CheckModified = (Datum >= tmpDate) And (Datum <= tmpDate + 6)
Case enuLastModifiedToday
CheckModified = Datum = Date
Case enuLastModifiedYesterday
CheckModified = Datum = Date - 1
End Select
End Function
Sub Transponieren(ByRef varArray)
Dim n&, nn&
Dim NewArray()
Redim Preserve NewArray(Lbound(varArray, 2) To Ubound(varArray, 2), Lbound(varArray) To Ubound(varArray))
For n = Lbound(varArray, 2) To Ubound(varArray, 2)
For nn = Lbound(varArray) To Ubound(varArray)
NewArray(n, nn) = varArray(nn, n)
Next nn
Next n
varArray = NewArray
End Sub
Gruß Tino