AW: Ergänzung in Makro
25.03.2023 20:01:24
JoWE
Hallo,
Einen entsprechenden Code, ich meine der ist von Nepumuk, hatte ich mir mal interessehalber kopiert, jedoch nie selbst getestet. Da sollte das Makro die Spielzeiten von Mediafiles ermitteln.
Die Angaben stehen dazu in Spalte A untereinander
Hilfts? Vllt. liest Nepumuk ja auch mit?!
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))
If Not IsEmpty(objCell.Value) Then
strFolderpath = objCell.Text
If Right$(strFolderpath, 1) > "\" Then strFolderpath = strFolderpath & "\"
If Dir$(strFolderpath, vbDirectory) = vbNullString 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
End If
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