Hallo Interessierte,
bis einschließlich Version 2003 wurde in Office.Vba sehr oft Filesearch benutzt um Dateien eines Ordners auszulesen.
MS hat in seiner grenzenlosen Weisheit *gg* entschieden daß es dies bei Offic2007 und Office2010 nicht mehr gibt.
D.h. alle die ganzen Codes die man die Jahre über entwickelt hat laufen nicht mehr aus diesem Grund.
Nachstehend ist Code von Nepumuk wie man Filesearch ersetzen kann.
Ich konnte im Code nichts Excelspezielles erkennen, also müßte der Code in allen ca. 30 Programmen funktionieren die VBA verwenden.
Gruß
Reinhard
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Modul: Modul1 Typ: Allgemeines Modul
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
'// Module : Modul1, Modul
'// Author : NEPUMUK at http://www.office-loesung.de/ftopic148247\_0\_0\_asc.php
'// Created : 28. Mai 2007
'// Modified :
'// Purpose : FileSearch
Option Explicit
Public Enum SORT\_BY
Sort\_by\_None
Sort\_by\_Name
Sort\_by\_Path
Sort\_by\_Size
Sort\_by\_Last\_Access
Sort\_by\_Last\_Modyfy
Sort\_by\_Date\_Create
End Enum
Public Enum SORT\_ORDER
Sort\_Order\_Ascending
Sort\_Order\_Descending
End Enum
Public Type FILEINFO
strFilename As String
strPath As String
lngSize As Long
dmtLastAccess As Date
dmtLastModify As Date
dmtDateCreate As Date
End Type
Public Sub Test()
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = True
.Extension = "\*.xls\*"
.FolderPath = "D:\Ausland\SBL"
.SearchLike = "\*"
.SubFolders = False
If .Execute(Sort\_by\_Name, Sort\_Order\_Ascending) \> 0 Then
MsgBox "There were " & .FileCount & \_
" file(s) found."
For lngIndex = 1 To .FileCount
MsgBox .Files(lngIndex).strFilename
Next lngIndex
Else
MsgBox "There were no files found."
End If
End With
Set objFileSearch = Nothing
End Sub
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Modul: clsFileSearch Typ: Klassenmodul
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
'// Module : clsFileSearch, Klassenmodul
'// Author : NEPUMUK at http://www.office-loesung.de/ftopic148247\_0\_0\_asc.php
'// Created : 28. Mai 2007
'// Modified :
'// Purpose : FileSearch
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( \_
ByVal lpFileName As String, \_
ByRef lpFindFileData As WIN32\_FIND\_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( \_
ByVal hFindFile As Long, \_
ByRef lpFindFileData As WIN32\_FIND\_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( \_
ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( \_
ByRef lpFileTime As FILETIME, \_
ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( \_
ByRef lpFileTime As FILETIME, \_
ByRef lpSystemTime As SYSTEMTIME) As Long
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 Const MAX\_PATH = 260&
Private Const INVALID\_HANDLE\_VALUE = -1&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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
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
Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Friend Property Get Files(lngIndex As Long) As FILEINFO
Files = mudtFiles(lngIndex)
End Property
Friend Property Get FileCount() As Long
FileCount = mlngFileCount
End Property
Friend Property Let FolderPath(strFolderPath As String)
mstrFolderPath = strFolderPath
End Property
Friend Property Let Extension(strExtension As String)
mstrExtension = strExtension
End Property
Friend Property Let SearchLike(strSearchLike As String)
mstrSearchLike = strSearchLike
End Property
Friend Property Let SubFolders(blnSubFolders As Boolean)
mblnSubFolders = blnSubFolders
End Property
Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
mblnCaseSenstiv = blnCaseSenstiv
End Property
Friend Function Execute(Optional enmSortBy As SORT\_BY = Sort\_by\_None, \_
Optional enmSortOrder As SORT\_ORDER = Sort\_Order\_Ascending) As Long
Call FindFiles(mstrFolderPath)
If mlngFileCount \> 1 And enmSortBy Sort\_by\_None Then \_
Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
Execute = mlngFileCount
End Function
Private Sub FindFiles(ByVal strFolderPath As String)
Dim WFD As WIN32\_FIND\_DATA, lngSearch As Long, strDirName As String
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "\*.\*", WFD)
If lngSearch INVALID\_HANDLE\_VALUE Then
Call GetFilesInFolder(strFolderPath)
If mblnSubFolders Then
Do
If (WFD.dwFileAttributes And FILE\_ATTRIBUTE\_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If (strDirName ".") And (strDirName "..") Then \_
Call FindFiles(strFolderPath & strDirName)
End If
Loop While FindNextFile(lngSearch, WFD)
End If
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & \_
Err.Description, vbCritical, "Fehler"
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String)
Dim WFD As WIN32\_FIND\_DATA, lngSearch As Long, strFilename As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
If lngSearch INVALID\_HANDLE\_VALUE Then
Do
If (WFD.dwFileAttributes And FILE\_ATTRIBUTE\_DIRECTORY) FILE\_ATTRIBUTE\_DIRECTORY Then
strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like \_
IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
mlngFileCount = mlngFileCount + 1
ReDim Preserve mudtFiles(1 To mlngFileCount)
With mudtFiles(mlngFileCount)
.strPath = strFolderPath & strFilename
.strFilename = strFilename
.lngSize = WFD.nFileSizeLow
FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + \_
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + \_
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + \_
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
End With
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & \_
Err.Description, vbCritical, "Fehler"
End Sub
Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT\_BY, enmSortOrder As SORT\_ORDER)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim udtBuffer As FILEINFO, vntTemp As Variant
lngIndex1 = lngLBorder
lngIndex2 = lngUBorder
Select Case enmSortBy
Case Sort\_by\_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
Case Sort\_by\_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
Case Sort\_by\_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
Case Sort\_by\_Last\_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
Case Sort\_by\_Last\_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
Case Sort\_by\_Date\_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
End Select
Do
Select Case enmSortBy
Case Sort\_by\_Name
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).strFilename vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).strFilename
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort\_by\_Path
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).strPath vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).strPath
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort\_by\_Size
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).lngSize vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).lngSize
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort\_by\_Last\_Access
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastAccess vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).dmtLastAccess
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort\_by\_Last\_Modyfy
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastModify vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).dmtLastModify
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort\_by\_Date\_Create
If enmSortOrder = Sort\_Order\_Ascending Then
Do While mudtFiles(lngIndex1).dmtDateCreate vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp \> mudtFiles(lngIndex2).dmtDateCreate
lngIndex2 = lngIndex2 - 1
Loop
End If
End Select
If lngIndex1 lngIndex2
If lngLBorder