AW: Dateinamen auslesen inkl. Unterordner
02.10.2008 13:29:44
fcs
Hallo markus,
hier eine leicht modifizierte Variante aus meinem Fundus.
Ansonsten kannst du ja den Teil zum Wählen des Ordners in deine Routine einbauen.
Gruß
Franz
Dim FSO, FO, FU, F
Dim lRow As Long
Dim icol As Integer
Sub Dateien_in_Verzeichnissen_Listen()
Dim varAuswahl As Variant, strDir As String
varAuswahl = Application.GetOpenFilename(Title:="Bitte Ordner wählen und dann abbrechen")
strDir = VBA.CurDir
If MsgBox(strDir & " auslesen?", vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
ActiveSheet.UsedRange.Clear
icol = 0
lRow = 0
lRow = lRow + 1
icol = icol + 1
Cells(lRow, icol) = strDir 'gewählten Ordner eintragen
Call DateienListen(strPath:=strDir)
GetSubFolders strDir
Application.ScreenUpdating = True
MsgBox "Fertig"
End Sub
Function GetSubFolders(Pfad)
Set FO = FSO.GetFolder(Pfad)
Set FU = FO.SubFolders
On Error Resume Next
For Each F In FU
lRow = lRow + 1
icol = icol + 1
Cells(lRow, icol) = F.Name 'Ordnername
Cells(lRow, icol).Interior.ColorIndex = 6 'gelb einfärben
If IsEmpty(F) Then 'Probleme beim Zugriff auf Unterordner
Cells(lRow, icol) = "!keine Leseberechtigung!"
icol = icol - 1
Else
If DateienListen(strPath:=F.Path) = False Then
Cells(lRow, icol) = "!Problem beim Dateien lesen!"
End If
End If
GetSubFolders F.Path
Next
icol = icol - 1
End Function
Private Function DateienListen(strPath As String) As Boolean
Dim objFile
On Error GoTo FEHLER
DateienListen = True
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
For Each objFile In .FoundFiles
lRow = lRow + 1
Cells(lRow, icol + 1) = Replace(objFile, IIf(Right(strPath, 1) = "\", strPath, _
strPath & "\"), "")
Next
End If
End With
Exit Function
FEHLER:
'Fehler beim Auslesen des Ordners
DateienListen = False
End Function