AW: Dateien und Ordner auslesen
08.04.2005 10:36:58
Martin
Hallo Rolf,
hat leider nicht so ganz geklappt. Da hat sich Excel bei mir aufgehängt. Trotzdem Danke!!
Habe aber dann doch noch was gefunden was mir hilft:
Public Sub Searching_files()
Dim myFileSystemObject As New FileSystemObject, myFile As File, myFileSearch As FileSearch
Dim strName() As String, strPath() As String, strPath_old As String
Dim lngIndex As Long, lngRow As Long, lngCount As Long, lngFolder As Long, lngStart As Long
Dim intColumn As Integer
Cells.Clear
Application.ScreenUpdating = False
Set myFileSearch = Application.FileSearch
With myFileSearch
.LookIn = strDrive
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
.Execute
On Error Resume Next
For lngIndex = 1 To .FoundFiles.Count
Set myFile = myFileSystemObject.GetFile(.FoundFiles(lngIndex))
If Err.Number = 0 Then
If Left$(myFile.ParentFolder, 1) = Left$(strDrive, 1) Then
lngCount = lngCount + 1
ReDim Preserve strName(1 To lngCount)
ReDim Preserve strPath(1 To lngCount)
strName(lngCount) = myFile.Name
strPath(lngCount) = myFile.ParentFolder
End If
End If
Err.Clear
Next
On Error GoTo 0
End With
Set myFile = Nothing
Set myFileSearch = Nothing
Call Arrange(1, lngCount, strName, strPath)
lngRow = 1
intColumn = 1
Call Heading(1)
For lngIndex = 1 To lngCount
If strPath_old strPath(lngIndex) Then
If lngRow > 1 Then Range(Cells(lngStart, intColumn), Cells(lngRow, intColumn)).Sort Key1:=Cells(lngStart, intColumn)
Call Row_control(lngRow, intColumn, 3)
With Cells(lngRow, intColumn)
.Value = strPath(lngIndex)
.Font.Bold = True
End With
lngFolder = lngFolder + 1
strPath_old = strPath(lngIndex)
Call Row_control(lngRow, intColumn, 1)
lngStart = lngRow + 1
End If
Call Row_control(lngRow, intColumn, 1)
Cells(lngRow, intColumn) = strName(lngIndex)
Next
Range(Cells(lngStart, intColumn), Cells(lngRow, intColumn)).Sort Key1:=Cells(lngStart, intColumn)
Call Row_control(lngRow, intColumn, 3)
With Cells(lngRow, intColumn)
.Value = "Dateien Gesamt: " & CStr(lngCount)
.Font.Bold = True
End With
Call Row_control(lngRow, intColumn, 1)
With Cells(lngRow, intColumn)
.Value = "Ordner Gesamt: " & CStr(lngFolder)
.Font.Bold = True
End With
Columns.AutoFit
Unload UserForm2
Application.ScreenUpdating = True
End Sub
Private Sub Arrange(lngBase_limit As Long, lngUpper_limit As Long, strName() As String, strPath() As String)
Dim lngIndex1 As Long, lngIndex2 As Long, strElement1 As String, strElement2 As String, strBuffer As String
lngIndex1 = lngBase_limit
lngIndex2 = lngUpper_limit
strBuffer = strPath(Fix(lngBase_limit + lngUpper_limit) / 2)
Do
Do While strPath(lngIndex1) < strBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While strBuffer < strPath(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
If lngIndex1 <= lngIndex2 Then
strElement1 = strName(lngIndex1)
strElement2 = strPath(lngIndex1)
strName(lngIndex1) = strName(lngIndex2)
strPath(lngIndex1) = strPath(lngIndex2)
strName(lngIndex2) = strElement1
strPath(lngIndex2) = strElement2
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngBase_limit < lngIndex2 Then Call Arrange(lngBase_limit, lngIndex2, strName, strPath)
If lngIndex1 < lngUpper_limit Then Call Arrange(lngIndex1, lngUpper_limit, strName, strPath)
End Sub
Private Sub Row_control(lngRow As Long, intColumn As Integer, bytCount As Byte)
lngRow = lngRow + bytCount
If lngRow > 65536 Then
lngRow = 1
intColumn = intColumn + 1
Call Heading(intColumn)
End If
End Sub
Private Sub Heading(intColumn As Integer)
With Cells(1, intColumn)
.Value = "Files on Drive: " & Left$(strDrive, 1)
With .Font
.Size = 12
.Bold = True
End With
End With
End Sub
Grüße,
Martin