Dateienauflistunf von 2003 auf 2007 umstellen
2003
Ich habe unter Office 2003 immer einen Code gehabt der mir Alle Dateien auflistet. Unter 2007 läuft der nicht mehr.
Könnt ihr da mal draufschauen und mir mal nen Lösungsansatz (bzw. eine ganz Lösung) geben:
Option Explicit
Dim FSO, FO, FU, F, c, a
Dim lRow As Long
Dim icol As Integer
Dim fd As FileDialog
Sub ORDNERVerz2()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Ordnerverzeichnis").Visible = True
If Sheets("Ordnerverzeichnis").Visible = True Then Sheets("Ordnerverzeichnis").Delete
Application.DisplayAlerts = True
Worksheets.Add Before:=ThisWorkbook.Worksheets(1)
With ActiveSheet
.Name = "Ordnerverzeichnis"
End With
Call Ordner_Auflisten2
Rows("1:1").Insert Shift:=xlDown
Range("A1") = "Ornder"
Range("B1") = "Unterordner 1"
Range("C1") = "Unterordner 2"
Range("D1") = "Unterordner 3"
Rows("1:1").Font.Bold = True
Cells.EntireColumn.AutoFit
Cells(1, 1).Select
End Sub
Public Sub Ordner_Auflisten2()
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
icol = 1
lRow = 1
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
Call DateienListen(strPath:=(fd.SelectedItems(1)))
GetSubFolders2 (fd.SelectedItems(1))
Else
Exit Sub
End If
Cells(1, 1) = fd.SelectedItems(1)
Application.ScreenUpdating = True
End Sub
Function GetSubFolders2(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
Cells(lRow, icol).Interior.ColorIndex = 6
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
GetSubFolders2 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
Vielen Dank
Rocky