filesearch 2000 - 2003 | Herbers Excel-Forum
Betrifft: filesearch 2000 - 2003
von: Herbert
Geschrieben am: 30.01.2010 14:46:16
Hallo Forumianer
Wir stellen laaaagsam um von 2000 auf 2003 und ich habe ein Programm, in dem ein FileSearch-Anteil drin ist. Ich habe zur Fehlersuche den in der VBA Hilfe vorhanden Code ausprobiert. Wenn ich diesen unter 2000 ausführe ist alles OK aber unter 2003 findet er keine Dateien, "There were no files found."
Sub test_search()
Set fs = Application.FileSearch
With fs
.LookIn = "D:\Ausland\SBL"
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub
Kann mir jemand helfen?
Gruß Herbert
Betrifft: AW: filesearch 2000 - 2003
von: Josef Ehrensberger
Geschrieben am: 30.01.2010 15:16:10
Hallo Herbert,
kann nicht sagen, warum es bei dir unter xl2003 nicht läuft, aber ich würde an deiner Stelle gleich eine Code nehmen, der auch in höheren Versionen läuft, die FileSearch nicht mehr unterstützen (xl2007, xl2010).
Eine sehr gute Alternative ist das Klassenmodul von Nepumuk. Siehe folgenden Code.
' **********************************************************************
' 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
Else
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
Else
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
Else
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
Else
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
Else
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
Else
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 Then
udtBuffer = mudtFiles(lngIndex1)
mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
mudtFiles(lngIndex2) = udtBuffer
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub
Gruß Sepp
Betrifft: AW: filesearch 2000 - 2003
von: Herbert
Geschrieben am: 30.01.2010 15:33:25
Hallo Sepp
WOW- jetz ist es bei mir mit meinen Kenntnissen vorbei. Hier mal der Code um den es geht:
Ich möchte in einer Userform "nur" Dateien anzeigen lassen und dann nach Auswahl in eine Tabelle zurückschreiben. Um dieses kleine Ergebnis zu bekommen - brauche ich den "Monstercode" (anerkennend)von Nepomuk? Das will ich nicht glauben.
Gruß Herbert
Option Explicit
Private Sub cmdList_Click()
Dim verz As String
Dim Pfad As Worksheet
Set Pfad = ThisWorkbook.Worksheets("Daten")
verz = ThisWorkbook.Worksheets("Daten").Range("B1").Value
On Error Resume Next
Pfad.Range("O2") = Right(lstFiles.Text, Len(lstFiles.Text) - 1)
Unload Me
End Sub
Private Sub cmdEnd_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim IntCounter As Integer
Dim verz As String
verz = ThisWorkbook.Worksheets("Daten").Range("B1").Value
With Application.FileSearch
.LookIn = verz
.Filename = "*.xls"
.Execute
For IntCounter = 1 To .FoundFiles.Count
lstFiles.AddItem Mid(.FoundFiles(IntCounter), Len(verz) + 1)
Next
End With
End Sub
Betrifft: AW: filesearch 2000 - 2003
von: Josef Ehrensberger
Geschrieben am: 30.01.2010 16:33:31
Hallo Herbert,
naja, Monstercode würd' ich die paar Zeilen nicht nennen. Der Code im Klassenmodul braucht dich nicht kümmern, du musst in nur in die Datei einfügen. Die Anwendung ist dann fast die selbe wie bei FileSearch mit dem großen Vorteil, das dieser Code in allen Versionen funktioniert.
Wie gesagt, kann ich nicht feststellen, warum .FileSearch bei dir unter xl2003 nicht läuft.
Gruß Sepp
Betrifft: AW: filesearch 2000 - 2003
von: Herbert
Geschrieben am: 30.01.2010 20:18:52
Hallo Sepp
Ich habe ein Klassenmodul eingefügt und den Code von Nepumuk hineinkopiert. Dann den anderen Code in ein allgemeines Modul eingefügt, nun bekomme ich die Fehlermeldung:
Fehler beim Kompilieren:
Benutzerdefinierter Typ nicht definiert
gleich am Beginn des Codes:
Public Sub Test()
Dim objFileSearch As clsFileSearch
was hab ich falsch gemacht?
Gruß Herbert
Betrifft: AW: filesearch 2000 - 2003
von: Josef Ehrensberger
Geschrieben am: 30.01.2010 20:20:06
Hallo Herbert,
das Klassenmodul musst du in "clsFileSearch" umbenennen.
Gruß Sepp
Betrifft: AW: filesearch 2000 - 2003
von: Herbert
Geschrieben am: 30.01.2010 20:54:22
Hallo Sepp
Danke, das hat jetzt funktioniert. Ich habe nun den Code in ein UserForm_Initialize ein gebaut um die Ausgabe in einer Userform umzulenken und bekomme nun im Klassenmodul bei
Private mudtFiles() As FILEINFO den gleichen Fehler.
Gruß Herbert
Option Explicit
Private Sub cmdList_Click()
Dim verz As String
Dim Pfad As Worksheet
Set Pfad = ThisWorkbook.Worksheets("Daten")
verz = ThisWorkbook.Worksheets("Daten").Range("B1").Value
On Error Resume Next
Pfad.Range("O1").Value = Right(lstFiles.Text, Len(lstFiles.Text) - 1)
Unload Me
End Sub
Private Sub cmdEnd_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim IntCounter As Integer
Dim verz As String
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long
Set objFileSearch = New clsFileSearch
verz = ThisWorkbook.Worksheets("Daten").Range("B1").Value
With objFileSearch
.CaseSenstiv = True
.Extension = "*.xls*"
.FolderPath = verz
.SearchLike = "*"
.SubFolders = False
.Execute
For lngIndex = 1 To .FileCount
lstFiles.AddItem Mid(.FoundFiles(lngIndex), Len(verz) + 1)
Next lngIndex
End If
End With
Set objFileSearch = Nothing
End Sub
Betrifft: AW: filesearch 2000 - 2003
von: Josef Ehrensberger
Geschrieben am: 30.01.2010 21:07:19
Hallo Herbert,
das wird ein Ratespiel.
Kanst du die Datei mit dem UF hochladen?
Gruß Sepp
Betrifft: AW: filesearch 2000 - 2003
von: Herbert
Geschrieben am: 30.01.2010 21:20:49
Hallo Sepp
Hab in der Forumsliste eine Code gefunden, auf eine Userform umgeschrieben und so das ganze ohne FileSearch gelöst:
Private Sub UserForm_Initialize()
Dim Fso, Ordner, varDatei
Dim DateiName As String
Dim SucheDatei As String
Dim verz As String
verz = ThisWorkbook.Worksheets(1).Range("B1").Value
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder(verz)
For Each varDatei In Ordner.Files
If varDatei Like "*" & "*.xls" Then
lstFiles.AddItem varDatei
End If
Next varDatei
End Sub
Damit werden die Dateien in die Userform eingelesen und ich kann sie in eine Tabelle zurückschreiben. Danke für Deine Hife und Geduld
Viele Grüße Herbert
Betrifft: AW: filesearch 2000 - 2003
von: JOWE
Geschrieben am: 30.01.2010 15:25:24
Hallo Herbert,
mit meinem Excel2003 klappt Dein Code fehlerfrei.
Existiert Dein Pfad und gibt es dort xls-Files?
Gruß
Jochen
Betrifft: AW: filesearch 2000 - 2003
von: Reinhard
Geschrieben am: 30.01.2010 17:26:27
Hallo Herbert,
ich hatte mal Code mit Filesearch der versagte in XL97 und zwar weil er irgendwie Laufwerke die Sticks sind nicht auslesen kann.
Aber mit XL2000 klappte das problemlos.
Diese Info nützt dir jetzt nix. Aber, andere mit 2003 haben ja wohl deinen Code getestet, da lief er.
Da stellt sich mir die Frage ob dein laufwerk D etwas anderes bedeutet als die laufwerke auf dennen es andere getestet haben.
Netzwerk, Stick, ...
Just my 2 Cents.
Gruß
Reinhard