Microsoft Excel

Herbers Excel/VBA-Archiv

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

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