Ordner & Unterordner durchsuchen
28.03.2019 16:28:30
Tim
ich habe ein Makro welches mir in einem Laufwerksordner, die Ordnerbezeichnung suchen soll, um mir anschließend den Inhalt als Pfad in eine Listbox ausgibt.
Das Ganze funktioniert sehr gut.
Jetzt gibt es aber auch verschiedene Dokumente (z.B. PDF, Doc, xlsx, usw.) die sich in keinem Unterordner befinden, die mit dem aktuellen Makro nicht gefunden werden, da er ja nur Ordnerbezeichnungen sucht.
Ziel soll es sein, dass der Suchbegriff aus Textbox1 Ordnerbezeichnungen und Dateibezeichnungen sucht.
Wer kann mir dabei helfen, dass ich sowohl als auch suchen kann!?
Option Explicit
Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
Private Const SW_SHOWNORMAL As Long = 1
Function FindFiles(ByVal Path As String, Optional ByVal Filter As String = "*", Optional ByVal Internal As Boolean) As Collection
Dim File As Object, Folder As Object, SubFolder As Object
Static FS As Object, Files As Collection
'On Error Resume Next
On Error GoTo Fehler
If Files Is Nothing Or Not Internal Then Set Files = New Collection
If FS Is Nothing Then Set FS = CreateObject("Scripting.FileSystemObject")
Set Folder = FS.GetFolder(Path)
For Each File In Folder.Files
If File.Name Like Filter Then Files.Add File.Path
Next
For Each SubFolder In Folder.SubFolders
FindFiles SubFolder.Path, Filter, True
Next
Set FindFiles = Files
Exit Function
Fehler:
MsgBox "zu deiner gesuchten Paketnummer """ & TextBox1.Value & """ existieren keine Dokumente!"
End Function
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
If KeyCode = vbKeyReturn Then
ListBox1.Clear
Dim Suchbegriff As String
Suchbegriff = TextBox1.Value
Dim File
For Each File In FindFiles("M:\Test\Belege\" & Suchbegriff)
ListBox1.AddItem File
Next
End If
End Sub