Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1132to1136
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zuletzt gespeicherte Datei aus Unterordnern suchen

Zuletzt gespeicherte Datei aus Unterordnern suchen
Annette
Hallo,
ich bräuchte ein Makro, das mir die zuletzt gespeicherte Datei von einer beliebigen Anzahl von Unterordnern sucht.
Zurückgegeben werden sollten der Dateienname, der Name des Unterordners und die Uhrzeit der letzten Änderung.
Ich habe es bereits mit FileDateTime versucht, komme aber nicht weiter.
Vielen Dank
Grüße
Annette
AW: Zuletzt gespeicherte Datei aus Unterordnern suchen
29.01.2010 19:32:09
Josef
Hallo Anette,
alle Dateitypen oder nur Exceldateien?
Alle Dateinamen oder nur Bestimmte?
Gruß Sepp

AW: Zuletzt gespeicherte Datei aus Unterordnern su
29.01.2010 19:42:48
Annette
Hallo Sepp,
Nur Exceldateien und Alle.
Danke
Gruß
Annette
AW: Zuletzt gespeicherte Datei aus Unterordnern su
29.01.2010 19:49:40
Josef
Hallo Anette,
kopiere den Code in ein allgemeines Modul.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub searchFile()
  Dim objFiles() As Object
  Dim strRoot As String, strFile As String, strDir As String
  Dim lngRes As Long, lngIndex As Long
  Dim dblFileTime As Double
  
  strRoot = "E:\" 'Startverzeichnis - Anpasen!
  
  lngRes = FileSearchINFO(objFiles, strRoot, "*.xls*", True)
  
  If lngRes > 0 Then
    For lngIndex = 0 To lngRes - 1
      If objFiles(lngIndex).DateLastModified > dblFileTime Then
        dblFileTime = objFiles(lngIndex).DateLastModified
        strFile = objFiles(lngIndex).Name
        strDir = objFiles(lngIndex).ParentFolder.Path
      End If
    Next
  End If
  
  If dblFileTime > 0 Then
    If MsgBox("Datei:" & vbTab & strFile & vbLf & "Ordner:" & vbTab & strDir & _
      vbLf & "Datum:" & vbTab & Format(dblFileTime, "dd.MM.yyyy hh:mm:ss") & vbLf & _
      vbLf & "Wollen Sie die Datei öffnen?", vbYesNo + vbInformation, "Hinweis") = _
      vbYes Then
      Workbooks.Open strDir & "\" & strFile
    End If
  End If
  
End Sub

'by J.Ehrensberger
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

  
  '# PARAMETERINFO:
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
  '# Beispiele: "*.txt" - Findet alle Textdateien
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
  
  
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant
  
  Set fobjFSO = CreateObject("Scripting.FileSystemObject")
  
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
  
  On Error GoTo ErrExit
  
  If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
  Else
    Redim varFiles(0)
    varFiles(0) = FileName
  End If
  For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
      For intC = 0 To UBound(varFiles)
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            Redim Preserve Files(UBound(Files) + 1)
          Else
            Redim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next
  
  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If
  
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
  ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
wie zaubert man sowas..
29.01.2010 20:05:31
robert
Hi Sepp,
..aus dem ärmel ? :-)
gruß
robert
AW: wie zaubert man sowas..
29.01.2010 20:13:18
Josef
Hallo Robert,
gar nicht. Die Funktion ist Bestand und das Drumherum ist ja nicht besonders schwierig.
Gruß Sepp

...naja, das sagst Du... ;-) owT
29.01.2010 20:22:55
robert
Super! Danke. LG Annette oT
29.01.2010 20:21:45
Annette
Klassenmodul von Nepumuk
29.01.2010 21:08:21
Nepumuk
Hallo,
auch wenn Annette soweit zufrieden ist sollte IMHO der Weg von Nepumuk Beachtung finden.
http://www.office-loesung.de/ftopic148247_0_0_asc.php
Unter XL2002 und XL2003:
Um zB alle Dateien im Laufwerk D zu durchlaufen (bei mir z.Z. ca. 90.000 Dateien) benötigt der Code von Nepumuk beim ersten Lauf ca. 1 Minute bei CPU Last 3%. Jeder weitere Suchlauf ist nach ca. 3 Sekunden abgeschlossen (bei CPU 100%). Der Filter (zB. Dateityp) ist dabei unerheblich.
Die Suche von Josef benötigt bei mir bei jedem Suchlauf 1-2 Minuten (bei CPU 100%).
wie gesagt bei XL2002 und 2003.
Nichts gegen dich, Josef - ich weiß deine Antworten hier im Forum immer sehr zu schätzen. Ich möchte auch nur darauf hinweisen, dass zumindest bei den früheren xls Versionen hier noch ein gewisses Potential besteht.
viele Grüße
Christian
Anzeige
AW: Klassenmodul von Nepumuk
29.01.2010 22:00:41
Nepumuk
Hallo Christian,
ich kenne und verwende den Code von Max, kommt halt immer darauf an, wie oft man
den Code braucht. Bei mehreren Suchen pro Tag geht bestimmt kein Weg daran vorbei,
wenn ich nur ab und zu suchen muss, tut's bestimmt die langsamere Variante auch.
Hier das Beispiel von vorhin mit der FileSearch von Max.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

'**************************************************************************************
'********************************STANDARDMODUL*****************************************
'**************************************************************************************

'// 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 = "E:\"
    .SearchLike = "*"
    .SubFolders = True
    If .Execute(Sort_by_Last_Modyfy, Sort_Order_Descending) > 0 Then
      With .Files(1)
        If MsgBox("Datei:" & vbTab & .strPath & vbLf & "Datum:" & vbTab & _
          .dmtLastModify & vbLf & vbLf & "Wollen Sie die Datei öffnen?", _
          vbYesNo + vbInformation, "Hinweis") = vbYes Then
          Workbooks.Open .strPath
        End If
      End With
    End If
  End With
  
  Set objFileSearch = Nothing
  
End Sub

' **********************************************************************
' Modul: clsFileSearch Typ: Klassenmodul
' **********************************************************************

'**************************************************************************************
'********************************KLASSENMODUL clsFileSearch****************************
'**************************************************************************************

'// 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

Anzeige
AW: Klassenmodul von Nepumuk
29.01.2010 22:32:56
Nepumuk
Hi Sepp,
ja, dass seh ich genau so. Beim ersten Suchlauf bringt es keinen bedeutenden zeitlichen Vorteil, aber bei Max's Code langweilt sich die CPU während dieser Zeit - das liegt wohl an MS Interna. Da ich ich häufig nach einer ersten Suche eine weitere starte, weiß ich den Code von Max Kaffl sehr zu schätzen.
Solange es um den Dateinamen und nicht um Dateiinhalte geht kommt auch die Dateisuche von MS nicht mit - und Google-Desktop scheitert an den Wildcards im Suchstring. Ich hab mir vor 2 Jahren mit dem Code von Max mal ein AddIn gebastelt und nutze es sehr häufig.
viele Grüße
Christian
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige