AW: subfolder bei Auflistung von folder berücksichtige
19.11.2013 14:33:50
folder
Hallo,
Sub DateiListe()
Dim FSO As Object, oFolder As Object, oDictF As Object
Dim strFolder As String, arrHeader, wksListe As Worksheet
Dim lngColumns As Long
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Ordner wählen"
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strFolder)
Set oDictF = CreateObject("Scripting.dictionary")
arrHeader = Array("Name", "Ext", "Ordner", "kB", "le.Änd.", "Erstellt", "Pfad")
lngColumns = UBound(arrHeader) + 1
prcFiles oFolder, oDictF
prcSubFolders oFolder, oDictF
On Error Resume Next
Set wksListe = ThisWorkbook.Sheets("DateiListe")
On Error GoTo 0
If wksListe Is Nothing Then
Set wksListe = Worksheets.Add(before:=Sheets(1))
wksListe.Name = "DateiListe"
End If
With wksListe
.Cells.Clear
.Cells(1, 1).Resize(, lngColumns) = arrHeader
.Cells(1, 1).Resize(, lngColumns).Font.Bold = True
If oDictF.Count > 0 Then
.Cells(2, 1).Resize(oDictF.Count, lngColumns) _
= WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDictF.Items))
Else
With .Cells(2, 1)
.Value = "No Files in " & oFolder
With .Font
.Bold = True
.Size = 16
.Color = RGB(255, 0, 0)
End With
End With
End If
.Columns.AutoFit
.Activate
End With
End Sub
Sub prcFiles(oFolder, oDictF)
Dim oFile As Object
For Each oFile In oFolder.Files
With oFile
oDictF(.Path) = Array( _
Left(.Name, InStrRev(.Name, ".") - 1), _
Replace(.Name, Left(.Name, InStrRev(.Name, ".")), ""), _
oFolder, _
Int(.Size / 1024), _
.DateLastModified, _
.DateCreated, _
.Path)
End With
Next
End Sub
Sub prcSubFolders(oFolder, oDictF)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
prcFiles oSubFolder, oDictF
prcSubFolders oSubFolder, oDictF
Next
End Sub
Gruß
Rudi