AW: Spielzeit von Videos ermitteln
26.12.2022 15:26:34
Videos
Hallo Rolf,
teste mal:
Option Explicit
Public Sub Beispiel()
Const FILE_PROPERTY = "Länge"
Const MAX_PROPERTYS = 400
Dim objShell As Object, objFolder As Object
Dim objCell As Range
Dim strFilename As String, strFolderpath As String
Dim lngIndex As Long, lngPosition As Long
Dim lngDays As Long, lngCount As Long
Dim dtmTotalTime As Date
Dim vntTemp As Variant
On Error GoTo error_exit
Set objShell = CreateObject(Class:="Shell.Application")
For Each objCell In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
strFolderpath = objCell.Text
If Right$(strFolderpath, 1) "\" Then strFolderpath = strFolderpath & "\"
If Dir$(strFolderpath, vbDirectory) = "" Then Call Err.Raise(Number:=vbObjectError, Description:="Ordner nicht gefunden.")
Set objFolder = objShell.Namespace(CVar(strFolderpath))
For lngIndex = 0 To MAX_PROPERTYS
If objFolder.GetDetailsOf(vbNullString, lngIndex) = FILE_PROPERTY Then
lngPosition = lngIndex
Exit For
End If
Next
If lngPosition = 0 Then Call Err.Raise(Number:=vbObjectError, Description:="Dateieigenschaft ''" & FILE_PROPERTY & "'' nicht gefunden.")
strFilename = Dir$(strFolderpath & "*.*", vbNormal)
Do Until strFilename = vbNullString
vntTemp = objFolder.GetDetailsOf(objFolder.ParseName(strFilename), lngPosition)
If IsDate(vntTemp) Then
dtmTotalTime = dtmTotalTime + CDate(vntTemp)
Else
lngCount = lngCount + 1
Debug.Print strFolderpath & strFilename
End If
strFilename = Dir$
Loop
lngDays = CLng(dtmTotalTime)
objCell.Offset(0, 1).Value = CStr(lngDays) & " Tage und " & Format$(dtmTotalTime - lngDays, "Hh:Nn:Ss")
If lngCount > 0 Then
objCell.Offset(0, 2).Value = CStr(lngCount) & " Datei(en) übersprungen"
Else
objCell.Offset(0, 2).Value = Empty
End If
lngDays = 0
dtmTotalTime = 0
lngCount = 0
Next
sub_exit:
Set objShell = Nothing
Set objFolder = Nothing
Exit Sub
error_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & Err.Description, vbCritical, "Fehler"
Resume sub_exit
End Sub
Gruß
Nepumuk