Option Explicit
Option Compare Text
Const sRootPath As String = "C:\Projekte"
Private lRowCounter As Long
Private oSheet As Object
Public Sub MWDateienMitUnterordnernAuslesen()
Set oSheet = Sheets.Add
oSheet.Activate
oSheet.Cells(1, 1).Select
Call CreateHeadLinesAndFormat
lRowCounter = 2
Call MWReadSubFolder(sRootPath)
Set oSheet = Nothing
Call HLinks
End Sub
Private Sub CreateHeadLinesAndFormat()
Dim i As Long
oSheet.Cells(1, 1) = "Pfad"
oSheet.Cells(1, 2) = "Dateiname"
oSheet.Cells(1, 3) = "Änderungsdatum"
oSheet.Columns(1).ColumnWidth = 40
oSheet.Columns(2).ColumnWidth = 40
oSheet.Columns(3).ColumnWidth = 40
For i = 1 To 2
With oSheet
.Cells(1, i).Interior.ColorIndex = 11
.Cells(1, i).Font.Color = vbWhite
.Cells(1, i).Font.Bold = True
End With
Next i
End Sub
Private Sub MWReadSubFolder(ByVal sPath As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
With oSheet
For Each oSubFolder In oFolder.subfolders
For Each oFile In oSubFolder.Files
.Cells(lRowCounter, 1) = oSubFolder.Path
.Cells(lRowCounter, 2) = oFile.Name
.Cells(lRowCounter, 3) = oFile.DateLastModified
lRowCounter = lRowCounter + 1
Next oFile
Call MWReadSubFolder(oSubFolder.Path)
Next oSubFolder
End With
Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oSubFolder = Nothing
End Sub
Wäre Euch sehr dankbar, wenn Ihr dort mal drüber schauen könntet....