Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Alternative zum Filesearch
zurück: Versteckte Userform-Funktionen weiter: Kleine Gegenüberstellung Excel 2003 und Excel 2007 Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Tutorial Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Nepumuk
VB / VBA Programmierer


Verfasst am:
28. Mai 2007, 03:33
Rufname: Max
Wohnort: Dusseldoof

Alternative zum Filesearch - Alternative zum Filesearch

Nach oben
       Version: Office 2k (2000)

Hallo,

nachdem es dieses Objekt in XL2007 nicht mehr gibt und in anderen Versionen nicht richtig funktioniert (Sortieren in XL2000 geht z.B. nicht), hier eine andere Möglichkeit.

In einem Standardmodul:
Code:
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:\"
        .SearchLike = "Test*"
        .SubFolders = True
        If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Debug.Print .strFilename, .lngSize
                End With
            Next
        End If
    End With
    Set objFileSearch = Nothing
End Sub
In einem Klassenmodul mit dem Namen clsFileSearch:
Code:
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

_________________
De fontibus non est disputandum

Gruß
Nepumuk Cool


Zuletzt bearbeitet von Nepumuk am 07. Okt 2007, 11:10, insgesamt einmal bearbeitet
< Peter >
Excel-Moderator, der immer noch dazu lernt


Verfasst am:
15. Jun 2007, 17:35
Rufname: Kommt darauf an wer ruft
Wohnort: Das schönste Land in Deutschlands Gaun


AW: Alternative zum Filesearch - AW: Alternative zum Filesearch

Nach oben
       Version: Office 2k (2000)

nimmt den Beitrag aus den unbeantworteten heraus.
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Alternative zu ZÄHLENWENN mit besserer Performance 5 maninweb 131 15. Apr 2014, 09:25
maninweb Alternative zu ZÄHLENWENN mit besserer Performance
Keine neuen Beiträge Excel Formeln: alternative für Verkettung von Zählenwenns 3 Zebulon54 104 12. März 2014, 22:12
Zebulon54 alternative für Verkettung von Zählenwenns
Keine neuen Beiträge Excel Formeln: Alternative zu Wenn Verschachtelung gesucht 6 Mick1_1 91 15. Feb 2014, 15:36
Mick1_1 Alternative zu Wenn Verschachtelung gesucht
Keine neuen Beiträge Excel Formeln: Alternative zu Verweis-Formel, wenn Datensatz sehr groß 8 Matilda87 90 05. Aug 2013, 14:29
Matilda87 Alternative zu Verweis-Formel, wenn Datensatz sehr groß
Keine neuen Beiträge Excel Formeln: Alternative zur Wenn-Funktion 4 Stefan_* 89 02. Jul 2013, 20:05
silex1 Alternative zur Wenn-Funktion
Keine neuen Beiträge Excel Formeln: Alternative zur LINKS Funktion 4 riraBN 188 13. Aug 2012, 11:03
riraBN Alternative zur LINKS Funktion
Keine neuen Beiträge Excel Formeln: alternative zu summewenns 5 mikmade 1325 25. Feb 2012, 20:30
mikmade alternative  zu summewenns
Keine neuen Beiträge Excel Formate: Eingabemeldungen - eine Alternative zu Kommentaren? 2 view2 1219 04. Feb 2011, 08:09
view2 Eingabemeldungen - eine Alternative zu Kommentaren?
Keine neuen Beiträge Excel Formeln: Alternative zu "Concatenate" und "If-Formeln& 9 Procurement Specialist 797 15. Jul 2010, 09:29
Procurement Specialist Alternative zu "Concatenate" und "If-Formeln&
Keine neuen Beiträge Excel Formeln: Alternative zu wverweis? 2 guy_incognito 1004 17. Jun 2010, 14:54
neopa Alternative zu wverweis?
Keine neuen Beiträge Excel Formeln: Ausschalten alternative Formelberechnung in Exel 2007 1 angelika_wimmer 1822 22. Feb 2010, 13:08
neopa Ausschalten alternative Formelberechnung in Exel 2007
Keine neuen Beiträge Excel Formeln: Alternative zu SVerweis? 6 Gast 595 12. Feb 2010, 23:37
Gast Alternative zu SVerweis?
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: PHP JavaScript