neuer Versuch
11.12.2013 15:02:28
Rudi
Sub prcFolders()
Dim FSO As Object, oFolder As Object
Dim strFolder As String, wksInhalt As Worksheet
Dim vntFiles(), lngFiles As Long
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder "" Then
Set oFolder = FSO.getfolder(strFolder)
prcFiles oFolder, vntFiles, lngFiles
prcSubFolders oFolder, vntFiles, lngFiles
vntFiles = WorksheetFunction.Transpose(vntFiles)
Set wksInhalt = Worksheets.Add
With wksInhalt
.Cells(1, 1) = "Pfad"
.Cells(1, 2) = "Dateiname"
.Cells(2, 1).Resize(UBound(vntFiles), 2).FormulaLocal = vntFiles
.Columns.AutoFit
.Activate
End With
End If
Application.ScreenUpdating = True
End Sub
Sub prcSubFolders(oFolder, vntFiles, lngFiles)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.subfolders
prcFiles oSubFolder, vntFiles, lngFiles
prcSubFolders oSubFolder, vntFiles, lngFiles
Next
End Sub
Sub prcFiles(oFolder, vntFiles, lngFiles)
Dim oFile As Object
For Each oFile In oFolder.Files
lngFiles = lngFiles + 1
ReDim Preserve vntFiles(1 To 2, 1 To lngFiles)
vntFiles(1, lngFiles) = oFolder.Path
vntFiles(2, lngFiles) = _
"=hyperlink(""" & oFile.Path & """;""" _
& oFile.Name & """)"
Next
End Sub
Gruß
Rudi