Sub GetFilesInFolder(FolderPath As String, GetSubfolders As Boolean)
Dim fso As Object, objFolder As Object
Dim subFolder, FileItem
Dim LastBlankCell As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(FolderPath)
Application.ScreenUpdating = False 'Disable Screen Updating to speed up macro
LastBlankCell = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Get the last blank cell of column A
If LastBlankCell = 2 Then
Range("A1:N1").Value = Array("#", "Name", "Base Name", "Attributes", "Path", "Size", _
"Type", "Extension", "Date Created", "Date Last Accessed", "Date Last Modified", "Länge", "Bildbreite", "Bildhöhe")
End If
On Error GoTo fehler '** Fehler abfangen!
For Each FileItem In objFolder.Files
FileExtension = UCase(fso.GetExtensionName(FileItem.Name)) 'Get file extension
Select Case FileExtension
Case "MKV", "AVI", "MP4" 'Get "MKV", "AVI", "MP4" files
Cells(LastBlankCell, 1) = LastBlankCell - 1 '#
Cells(LastBlankCell, 2) = FileItem.Name 'Name
Cells(LastBlankCell, 3) = fso.GetBaseName(FileItem.Name) 'Base Name
Cells(LastBlankCell, 4) = FileItem.Attributes 'Attributes
Cells(LastBlankCell, 5) = FileItem.Path 'Path
Cells(LastBlankCell, 6) = FileItem.Size / 1048576 'Size Format: 1024 "KB" / 1048576 "MB" / 1073741823 "GB"
Range("F2:F10000").NumberFormat = "0.00"" MB"""
Cells(LastBlankCell, 7) = FileItem.Type 'Type
Cells(LastBlankCell, 8) = FileExtension 'Extension
Cells(LastBlankCell, 9) = FileItem.DateCreated 'Date Created
Cells(LastBlankCell, 10) = FileItem.DateLastAccessed 'Date Last Accessed
Cells(LastBlankCell, 11) = FileItem.DateLastModified 'Date Last Modified
Cells(LastBlankCell, 12) = GetFileDetails(FileItem, 27) 'Length
Cells(LastBlankCell, 13) = GetFileDetails(FileItem, 316) ' Bildbreite
Cells(LastBlankCell, 14) = GetFileDetails(FileItem, 314) ' Bildhöhe
LastBlankCell = LastBlankCell + 1 'next row number
Case Else
End Select
Next FileItem
If GetSubfolders = True Then
'LastBlankCell = LastBlankCell - 2
For Each subFolder In objFolder.SubFolders
'** interne System Ordner überspringen!!
If InStr(oSubfolder, "RECYCLE") Then GoTo nx
If InStr(oSubfolder, "System Volume Information") Then GoTo nx
GetFilesInFolder subFolder.Path, True
nx: 'interne System Ordner überspringen!!
Next subFolder
End If
Set objFolder = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
fehler: MsgBox subFolder.Name: Resume Next
End Sub