Thema Datum  Von Nutzer Rating
Antwort
01.04.2020 20:14:53 Michel
NotSolved
01.04.2020 20:17:33 Michel
NotSolved
Rot OOo/LOo Macro Unterordner durchsuchen
02.04.2020 00:41:02 Gast34112
NotSolved
02.04.2020 08:10:59 RPP63
NotSolved

Ansicht des Beitrags:
Von:
Gast34112
Datum:
02.04.2020 00:41:02
Views:
574
Rating: Antwort:
  Ja
Thema:
OOo/LOo Macro Unterordner durchsuchen

Dateien suchen (Unterverzeichnisse eingeschlossen) - per Windows API.

Option Explicit

Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Const MAX_PATH As Long = 260&

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

Const FILE_ATTRIBUTE_ARCHIVE      As Long = &H20&
Const FILE_ATTRIBUTE_COMPRESSED   As Long = &H800&
Const FILE_ATTRIBUTE_DIRECTORY    As Long = &H10&
Const FILE_ATTRIBUTE_HIDDEN       As Long = &H2&
Const FILE_ATTRIBUTE_NORMAL       As Long = &H80&
Const FILE_ATTRIBUTE_READONLY     As Long = &H1&
Const FILE_ATTRIBUTE_SYSTEM       As Long = &H4&
Const FILE_ATTRIBUTE_TEMPORARY    As Long = &H100&

Public Function GetFiles(ByVal Path As String, ByVal FileExtensionFilter As String, ByRef Files As VBA.Collection) As Long
  
  If Right$(Path, 1) <> "\" Then Path = Path & "\"
  If FileExtensionFilter = "" Then Exit Function
  If Files Is Nothing Then Set Files = New VBA.Collection
  
  Dim fd        As WIN32_FIND_DATA
  Dim strFile   As String
  Dim hFile     As LongPtr
  
  hFile = FindFirstFile(Path & "*.*", fd)
  If hFile = 0 Then Exit Function
  
  Do
    strFile = Left$(fd.cFileName, InStr(fd.cFileName, vbNullChar) - 1)
    If (fd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
    '-> Verzeichnis
      If strFile <> "." And strFile <> ".." Then
      '-> rekursiv weiter suchen...
        Call GetFiles(Path & strFile, FileExtensionFilter, Files)
      End If
    Else
    '-> Datei
      If strFile Like FileExtensionFilter Then
        Call Files.Add(Path & strFile)
      End If
    End If
  Loop While FindNextFile(hFile, fd)
  
  Call FindClose(hFile)
  
  GetFiles = Files.Count
  
End Function

 

Beispielaufruf:

Public Sub Test()
  
  Dim colFiles  As VBA.Collection
  Dim vntFile   As Variant
  
  Set colFiles = New VBA.Collection
  
  If GetFiles("X:\RootFolder\SubFolder\", "*.sxw", colFiles) > 0 Then
    
'    For i = 1 To colFiles.Count
    For Each vntFile In colFiles
      Debug.Print vntFile
    Next
    Debug.Print "files found:"; colFiles.Count
    
    Call MsgBox(colFiles.Count & " Dateien gefunden.", vbInformation)
    
  Else
    Call MsgBox("Nix gefunden.", vbInformation)
  End If
  
End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
01.04.2020 20:14:53 Michel
NotSolved
01.04.2020 20:17:33 Michel
NotSolved
Rot OOo/LOo Macro Unterordner durchsuchen
02.04.2020 00:41:02 Gast34112
NotSolved
02.04.2020 08:10:59 RPP63
NotSolved