AW: Spielzeit von MP4 Dateien auslesen
18.05.2024 11:24:21
Oppawinni
Ich hab das mal wieder auf Medien-Files geändert.
Da musst du jetzt halt noch irgendwo dein Textfile generieren.
Das könntest du da hinein wurschteln, oder halt etwas anhängen, das die Ausgabe wieder liest und in einen Textdatei schreibt.
Option Explicit
'Listet für einen vom Benutzer gewählten Ordner und dessen Unterordner
'jeweils auf einem neuen Arbeitsblatt alle Dateien der Typen mp4;mkv;avi;flv
'
'Ursprungscode https://www.herber.de/forum/archiv/1928to1932/1929342_Zugriff_verweigert.html
'
'Aus Geschwindigkeitsgründen:
'Kontrollausgaben entfernt
'Ausgabe wird in Array vorbereitet
'Hyperlinks ergänzt (und jetzt per Formel)
'DoEvents lass ich mal drin
Private oApp As Object
Private oFSO As Object
Private dtStart As Date
Private arrOut As Variant
Private rngStartOut As Range
Private t(4) As Variant
Const cFilesRead = 0
Const cLinesCount = 1
Const cTimeElapsed = 2
Const cPathNoReadPerm = 3
Const cPathSysHid = 4
Public Sub OVBAde_ListMediaFilesRecursive()
Dim oSheet As Worksheet
Dim sRootPath As String
Dim objFileDialog As Object
Dim shApp As Object
Dim i As Long
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Bitte den Ordner auswählen"
If .Show Then sRootPath = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If sRootPath = "" Then
Exit Sub
End If
dtStart = Now
t(cFilesRead) = 0
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
t(cPathNoReadPerm) = 0
t(cPathSysHid) = 0
t(cLinesCount) = 0
dtStart = Now
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oApp = CreateObject("Shell.Application")
ReDim arrOut(7, 800)
Set oSheet = Sheets.Add
'Titelzeile erstellen
With oSheet.Range("A1:H1")
.Value = Array("Datei", "Typ", "Größe", "Stand", "Ordner", "Dauer", "Fr_Höhe", "Fr_Breite")
.Interior.ColorIndex = 11
.Font.Color = vbWhite
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
End With
Set rngStartOut = oSheet.Range("A2")
If oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).Path = sRootPath Then
OVBAde_ReadSubFolder oFSO.GetDrive(oFSO.GetDriveName(sRootPath)).RootFolder, "mp4;mkv;avi;flv"
Else
OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath), "mp4;mkv;avi;flv"
End If
'Ausgabe der letzten Daten und Autofit
ReDim Preserve arrOut(UBound(arrOut, 1), t(cLinesCount) - 1)
putArray
oSheet.Columns.AutoFit
t(cTimeElapsed) = Format(Now - dtStart, "hh:mm:ss")
MsgBox "Files gelesen " & vbTab & ": " & t(cFilesRead) & 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 Object, Optional strExtList As String = "")
Dim oSubFolder As Object
Dim oFile As Object
'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
Dim shfolder As Object
Dim shfolderitem As Object
Set shfolder = oApp.Namespace(oFolder.Path)
'Alle Dateien durchforsten
For Each oFile In oFolder.Files
If Not oFile Is Nothing Then
If strExtList = "" Or (InStr(1, ";" & strExtList & ";", ";" & oFSO.GetExtensionName(oFile.Name) & ";") > 0) Then
Set shfolderitem = shfolder.ParseName(oFile.Name)
Details_auslesen shfolder, shfolderitem
End If
End If
Next
Set shfolder = Nothing
Set shfolderitem = Nothing
'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, strExtList
Else
t(cPathSysHid) = t(cPathSysHid) + 1
End If
Next oSubFolder
End Sub
Private Sub Details_auslesen(shfolder As Object, item As Object)
Dim lngArrSize As Long
lngArrSize = UBound(arrOut, 2)
If t(cLinesCount) = lngArrSize Then
putArray
End If
arrOut(0, t(cLinesCount)) = item.Name
arrOut(1, t(cLinesCount)) = item.Type
arrOut(2, t(cLinesCount)) = item.Size
arrOut(3, t(cLinesCount)) = item.ModifyDate
arrOut(4, t(cLinesCount)) = shfolder.self.Path
arrOut(5, t(cLinesCount)) = shfolder.GetDetailsOf(item, 27)
arrOut(6, t(cLinesCount)) = shfolder.GetDetailsOf(item, 314)
arrOut(7, t(cLinesCount)) = shfolder.GetDetailsOf(item, 316)
t(cLinesCount) = t(cLinesCount) + 1
t(cFilesRead) = t(cFilesRead) + 1
End Sub
Private Sub putArray()
Dim i As Long
rngStartOut.Resize(UBound(arrOut, 2) + 1, UBound(arrOut, 1) + 1) = WorksheetFunction.Transpose(arrOut)
For i = 0 To UBound(arrOut, 2)
rngStartOut.Offset(i, 0).FormulaR1C1 = "=HYPERLINK(RC[4]&""\" & arrOut(0, i) & """,""" & arrOut(0, i) & """)"
Next
Set rngStartOut = rngStartOut.Offset(t(cLinesCount))
t(cLinesCount) = 0
DoEvents
End Sub
