AW: Na dann good luck!! Nix für Ungut! o.T.
06.05.2023 00:34:58
Pappawinni
So, also da dann der Code, der alle Dateien raus wirft, extra für Rosel.
Da sind halt jetzt auch die Kontrollausgaben drinnen, bin zu faul jetzt nochmal raus zu werfen.
Option Explicit
'Listet für einen fest im Code hinterlegten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien
'für Dateien der Typen mp4, mkv, avi, flv mit zusätzlichen Attributen
'(z.B. um Inhalte verschiedener Wechseldatenträger zu erfassen)
'vollständig überarbeitet und getestet im Mai 3023
'
'Ursprungscode bereitgestellt von Rosel auf herber.de mit dem Kommentar:
'Code von YAL leicht ergänzt, korrigiert.
'unter Anbindung von "Microsoft Scripting Runtime" ("Extras", "Verweise...", einhaken)
'Start der Routine: OVBAde_DateienMitUnterordnernAuslesen
Private oSheet As Worksheet
Private oFSO As FileSystemObject
Private dtStart As Date
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesOut = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_DateienMitUnterordnernAuslesen()
'Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Const sRootPath As String = "C:"
dtStart = Now
t(cLinesOut) = 0
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
dtStart = Now
Set oFSO = New FileSystemObject
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:G1")
.Value = Array("Pfad", "Datum", "Dateiname", "Grösse", "Länge", "Fr_Höhe", "Fr_breite")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
'Titel für Zähleranzeige während der Laufzeit
oSheet.Range("i1:M1").Value = Array("Files geprüft", "Files ausgeg.", "Laufzeit", "Folder o. Rechte", "Folder Sys/Hidden")
oSheet.Range("i2:M2").Value = t
oSheet.Range("i1:M2").Columns.AutoFit
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End If
'Zähleranzeige entfernen
oSheet.Range("i1:M2").Clear
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files geprüft " & vbTab & ": " & t(cFilesRead) & vbCrLf & _
"Files ausgegeben" & vbTab & ": " & t(cLinesOut) & vbCrLf & _
"Laufzeit " & vbTab & ": " & t(cTimeElapsed) & vbCrLf & vbCrLf & _
"Folder o. Leserechte" & vbTab & ": " & t(cPathNoReadPerm) & vbCrLf & _
"Folder Syst./Hidden" & vbTab & ": " & t(cPathSysHid)
End Sub
Private Sub OVBAde_ReadSubFolder(oFolder As Folder)
Dim oSubFolder As Folder
Dim oFile As Scripting.File
'Testet ob Verzeichnis gelesen werden kann
On Error Resume Next
If Not (oFolder.Files.Count >= 0) Then
t(cPathNoReadPerm) = t(cPathNoReadPerm) + 1
Exit Sub
End If
On Error GoTo 0
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
Details_auslesen oFile
End If
Next
'Alle Unterverzeichnisse verarbeiten (rekursiv), die nicht System oder Hidden sind
For Each oSubFolder In oFolder.subfolders
If Not ((oSubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
OVBAde_ReadSubFolder oSubFolder
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Sub Details_auslesen(Datei As File)
Dim ShApp As Object 'Shell-Objekt
Dim ShFolder As Object 'Folder-Objekt (nach Shell-App Muster, nicht nach FileSystemObject)
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
Const cExtListe = "!mp4!mkv!avi!flv!"
DoEvents
t(cFilesRead) = t(cFilesRead) + 1
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
oSheet.Range("i2:M2").Value = t
If Not (InStr(1, cExtListe, "!" & oFSO.GetExtensionName(Datei.Name) & "!") > 0) Then
t(cLinesOut) = t(cLinesOut) + 1
With oSheet.Cells(t(cLinesOut), 1)
.Offset(1, 0).Value = Datei.Path
.Offset(1, 1).Value = Datei.DateLastModified
.Offset(1, 2).Value = Datei.Name
End With
Exit Sub
End If
oSheet.Cells(2, 10).Value = oSheet.Cells(2, 10).Value + 1
Set ShApp = CreateObject("Shell.Application")
Set ShFolder = ShApp.Namespace(Datei.ParentFolder.Path)
Set ShFolderItem = ShFolder.ParseName(Datei.Name)
t(cLinesOut) = t(cLinesOut) + 1
With oSheet.Cells(t(cLinesOut), 1)
.Offset(1, 0).Value = Datei.Path
.Offset(1, 1).Value = Datei.DateLastModified
.Offset(1, 2).Value = Datei.Name
.Offset(1, 3).Value = ShFolder.GetDetailsOf(ShFolderItem, 1) 'Size
.Offset(1, 4).Value = ShFolder.GetDetailsOf(ShFolderItem, 27) 'Length
.Offset(1, 5).Value = ShFolder.GetDetailsOf(ShFolderItem, 314) 'Frame Height
.Offset(1, 6).Value = ShFolder.GetDetailsOf(ShFolderItem, 316) 'Frame Width
End With
End Sub