Sleeper: Get duration of mp4 files

[entwined]

Hello experts,

I would like to ask if there is a way to get the duration/length of video files (mine is mp4 file only) through vba code. The mp4's are located in one folder. A simple excel list will do for me (example below).

Filename Length
9001.mp4 00:28:36
9002.mp4 00:18:03
9003.mp4 00:20:09
9004.mp4 00:24:14

Any help will be very much appreciated. Thanks in advance.

[JBeaucaire]

A generic tool for collecting specific properties of video files, add/remove the extensions you want to include in the ARRAY and then tweak the top path in the SHELL command, currently it starts at C:\ and dives into all folders from there, so it will find them all. Not the quickest, but it's thorough.

Option Explicit
Sub GetVideos()
    Dim fileType, fileNames, movieFile
    Dim nextRow As Excel.Range
     
    For Each fileType In Array(".avi", ".mkv", ".mpeg4", ".mov") '// add more as required...
         '// Black console box may appear at this point for a while, this is normal...
        fileNames = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR ""C:\*" & fileType & """ /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
        For Each movieFile In fileNames
            Set nextRow = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            nextRow.Value = GetProperties(CStr(movieFile), 0)
            nextRow.Offset(0, 1).Value = GetProperties(CStr(movieFile), 1)
            nextRow.Offset(0, 2).Value = GetProperties(CStr(movieFile), 27)
            nextRow.Offset(0, 3).Value = GetProperties(CStr(movieFile), 182)
            nextRow.Offset(0, 4).Value = GetProperties(CStr(movieFile), 284)
        Next
    Next
     
    With Range("A1:E1")
        .Value = Array("Name", "Size", "Length", "Type", "Frame Rate")
        .EntireColumn.AutoFit
    End With
     
End Sub
 
Function GetProperties(file As String, propertyVal As Integer) As Variant
Dim varfolder, varfile
    With CreateObject("Shell.Application")
        Set varfolder = .Namespace(Left(file, InStrRev(file, "\") - 1))
        Set varfile = varfolder.ParseName(Right(file, Len(file) - InStrRev(file, "\")))
        GetProperties = varfolder.GetDetailsOf(varfile, propertyVal)
    End With
End Function

[ashleedawg]

A quicker/alternate method:

Function GetVideoDuration(fPName As String) As Long
'returns the duration in seconds of the specified video path+fPNamename
    Dim oFolder, ofPName
    With CreateObject("Shell.Application")
        Set oFolder = .Namespace(Left(fPName, InStrRev(fPName, "\") - 1))
        Set ofPName = oFolder.ParseName(Right(fPName, Len(fPName) - InStrRev(fPName, "\")))
        GetVideoDuration = CDbl(TimeValue(oFolder.GetDetailsOf(ofPName, 27))) * 24# * 60# * 60#
    End With
End Function

Usage:

MsgBox GetVideoDuration("x:\myPath\myVideo.mp4")  'returns a duration in seconds

...to instead have the duration represented a HH:MM:SS, shorten the third-to-last line to:

GetVideoDuration = oFolder.GetDetailsOf(ofPName, 27)

[Desadas]

In my opinion, the most convenient way is the MsgBox command. Through it will specify the duration of the video file in seconds. There is only one problem with this command. It has to do with changing the file format. When I need to get the file's duration in AVI format, time is not displayed for some reason. I partially solved this problem by just converting the file to MP4 at convertr.org. But still, I need other options to solve this problem. If anyone has encountered something like this, I would be glad if you could share your thoughts.

[arnelgp]

Private Sub testMe()
Const path As String = "c:\thePathOfMp4Here\"
Dim sFile As String
Dim c_file As New Collection
Dim i As Integer
sFile = Dir$(path & "*.mp4")
Do Until Len(sFile) = 0
    i = i + 1
    c_file.Add key:=i & "", Item:=sFile
    sFile = Dir$
Loop
For i = 1 To c_file.count
    With Range("A1")
        .Offset(i-1,0) = c_file.Item(i)
        .Offset(i-1,1) = getDuration(path, c_file.Item(i))
    End With
Next
End Sub


Public Function getDuration(ByVal path As String, ByVal file As String) As Variant
    With CreateObject("Shell.Application").NameSpace(path & "")
        getDuration = .GetDetailsOf(.Items.Item(file & ""), 27)
    End With
End Function

[gmayor]

The following, based on arnelgp's function, will recover the durations of a variety of video files in a folder, including AVI and MP4, here written to the immediate window.

Public Sub GetFileProperty()
Dim sPath As String
Dim sFile As String
Const lngLength As Long = 27

    sPath = "C:\Path of Video files\"
    sFile = Dir$(sPath & "*.*")
    Do While sFile <> ""
        Select Case Right(LCase(sFile), 3)
            Case "mkv", "avi", "mp4"
Debug.Print sFile & " - Length: " & getDuration(sPath, sFile, lngLength)
            Case Else
        End Select
        sFile = Dir$()
    Loop
End Sub

Private Function getDuration(ByVal sPath As String, ByVal sFile As String, lngLength As Long) As Variant
Dim oShell As Object
Dim sDuration As String
Dim sLength As String
Dim vTime As Variant
Dim sHrs As String, sMins As String, sSecs As String
    Set oShell = CreateObject("Shell.Application")
    With oShell.NameSpace(sPath & "")
        sLength = .GetDetailsOf(.Items.Item(sFile & ""), lngLength)
        vTime = Split(sLength, Chr(58))
        sHrs = "": sMins = "": sSecs = ""
        If UBound(vTime) = 2 Then
            If Val(vTime(0)) > 0 Then
                sHrs = Format(vTime(0), "0") & " hour"
                If Val(vTime(0)) > 1 Then
                    sHrs = sHrs & "s "
                Else
                    sHrs = sHrs & " "
                End If
            End If
            If Val(vTime(1)) > 0 Then
                sMins = Format(vTime(1), "0") & " minute"
                If Val(vTime(1)) > 1 Then
                    sMins = sMins & "s "
                Else
                    sMins = sMins & " "
                End If
            End If
            If Val(vTime(2)) > 0 Then
                sSecs = Format(vTime(2), "0") & " second"
                If Val(vTime(2)) > 1 Then
                    sSecs = sSecs & "s "
                Else
                    sSecs = sSecs & " "
                End If
            End If
            getDuration = sHrs & sMins & sSecs
        End If
    End With
    Set oShell = Nothing
End Function