AW: Ordner suchen ohne API
09.04.2005 17:31:30
Rolf
Hallo Nepumuk,
geht auch mit Bordmitteln - s.u.
hG
Rolf
'angepasstes Hilfebeispiel
'Aufgabe
'der PC (msoSearchInMyComputer) wird
'nach einem definierten Verzeichnis (const foldspec)
'nach den definierten Dateitypen (msoFileType) durchsucht
Option Explicit
Sub SearchEveryFolder()
On Error Resume Next
Dim ss As SearchScope
Dim sf As ScopeFolder
Dim lngCount As Long
Const foldspec = "MyFolder"
Call collect_delete
With Application.filesearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
For Each ss In .SearchScopes
Select Case ss.Type
Case msoSearchInMyComputer
For Each sf In ss.ScopeFolder.ScopeFolders
Call OutputPaths(sf.ScopeFolders, foldspec)
Next sf
Case Else
End Select
Next ss
If .SearchFolders.Count > 0 Then
.LookIn = .SearchFolders.Item(1).Path
If .Execute <> 0 Then
MsgBox "Files found: " & .FoundFiles.Count
Sheets.Add
For lngCount = 1 To .FoundFiles.Count
Cells(lngCount, 1) = .FoundFiles.Item(lngCount)
Next lngCount
End If
End If
End With
End Sub
'Altsuche löschen
Sub collect_delete()
Dim lngCount As Integer
With Application.filesearch
For lngCount = .SearchFolders.Count To 1 Step -1
.SearchFolders.Remove lngCount
Next lngCount
End With
End Sub
Sub OutputPaths(ByVal sfs As ScopeFolders, _
ByRef strFolder As String)
Dim sf As ScopeFolder
For Each sf In sfs
If LCase(sf.Name) = LCase(strFolder) Then
sf.AddToSearchFolders
End If
DoEvents
If sf.ScopeFolders.Count > 0 Then
Call OutputPaths(sf.ScopeFolders, strFolder)'rekursiv!!!
End If
Next sf
End Sub