Read/write extended file properties (solved)

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
This refers to VIDEO files. For MP3 files, which work better across applications, please see my code in http://www.mrexcel.com/forum/showthread.php?t=322393

If we look at video file properties in, say, Windows Media Player, RealPlayer, and Windows Explorer there are different ones depending on the application and file type. Trying to manually set individual file properties is time consuming and they only show in the application used to set them. A simple check in Windows Explorer file properties shows that things like Date Created, Modified, and File Size do not always match what we see in the file list windows. (I use the FileSystemObject ones). My code does not address this problem, but at least makes it possible to READ and WRITE properties in batches. Having files in a worksheet table enables use of things like sorting and Autofilter, as well as copy/paste etc. to change data. We can also add other macros to delete files and auto-open the appropriate Explorer folder window etc.

Having made numerous experiments I have found that the published methods of writing properties in Visual Basic do not work in VBA. However, we are able to use an (invisible) 'Windows Media Player' control in a Userform to do the job. Although we can read 82 video properties they are not all suitable for writing, and they vary depending on the type. I only really need 3 custom ones, so have chosen Title, Genre, and Content Provider because they show columns in the WMP application too. Because Windows Media Player is not compatible with all video file types (eg.VOB) I use the read-only Shell Properties. There are 287 available in my setup (not all are appropriate to a particular file type).

Please carefully read the other notes contained in the code, and make tests too. Although I have found no problems, you use the macros at your own risk. We are changing file structures. I am using Windows 7 64bit, Windows Media Player 12, and Excel 2000.

METHOD :
1. Requires a worksheet called "Library". Copy/paste the worksheet code below to the module for the sheet.

2. Add a userform with 3 buttons and a Windows Media Player Control. In the Custom\General tab properties for WMP select "Invisible" under Controls Layout, and uncheck "Auto start". Copy/paste my userform code. Check that VB Editor Tools/References shows "Windows Media Player".

3. READ to the worksheet. Set the base folder in the code and run the userform. Click Button 1 to pick up all subfolders & files.
(eg. all my files are on drive F:\ - so that is where I start)

4. WRITE - Manually change properties in worksheet columns A,B & C, and then click Button 2 to run the write macro. It looks for "X" in column P for the ones to change (put there manually or by the Worksheet_Change macro)

5. Worksheet_Change macro. Puts X in column P to indicate when a data change is made.

6. Worksheet_BeforeDoubleClick macro to play a video in the desired application (amend path etc. as necesary).

Code:
'=============================================================================
'- Copy/Paste all this code to a userform
'- Needs 3 buttons & a WindowsMediaPlayer control (set invisible)
'- The READ code does not change files - but test first and use at your own risk
'=============================================================================
'- BUTTON 1 : READ EXTENDED VIDEO FILE PROPERTIES TO A WORKSHEET
'- LISTS ALL AVI/WMV/MPG/VOB FILES IN FOLDERS & SUBFOLDERS OF *BASE FOLDER*
'- Uses WindowsMediaPlayer Control to read the 3 properties that I write to.
'- Uses Shell for ReadOnly properties - it reads practically all file types.
'- NB. Not all properties are the same format, even in the same file type.
'-----------------------------------------------------------------------------
'- BUTTON 2 : WRITES 3 CUSTOM PROPERTIES FROM WORKSHEET COLUMNS A,B,C.
'-----------------------------------------------------------------------------
'- Brian Baulsom June 2010
'=============================================================================
Const BaseFolder As String = "F:\TEST\"      ' *BASE FOLDER*
'=============================================================================
'- FileSystemObject
Dim FSO As Object
Dim FolderName As String
Dim FolderPath As String
Dim FolderSpec As String
Dim MyFolder As String
Dim FileCount As Long
'-----------------------------------------
'- PROPERTIES
Dim fsoCreated As Variant   ' file property
Dim fsoModified As Variant  ' file property
Dim fsoSize As Variant      ' file property
Dim MySplit As Variant      ' to get subfolder
Dim SubFolder As String
'-----------------------------------------------------------------------------
'- WINDOWS MEDIA PLAYER PROPERTIES Read/Write (userform control)
Dim WMP As WindowsMediaPlayer
'- CUSTOMISABLE PROPERTIES USED HERE
Dim wmpTitle As String   ' item 40
Dim wmpGenre As String   ' item 61
Dim wmpContent As String ' 58 WM/ContentDistributor = WMP "Content Provider"
'-----------------------------------------------------------------------------
'- SHELL PROPERTIES (Read Only)(WMP does not handle VOB properties very well)
Dim ShellObj As shell
Dim ShellFolder As Folder
Dim ShellFolderItem As FolderItem
'- PROPERTIES                   ' item
Dim shDuration  As Variant      '  27    'Length'
Dim shFrameRate As Variant      ' 281
Dim shFrameHeight As Variant    ' 280
Dim shFrameWidth As Variant     ' 282
Dim shBitrate As Variant        ' 283
Dim shFormat As Variant         ' 277     'Video Compression'
'-----------------------------------------------------------------------------
'- General
Dim MyRegExp As Object
Dim VideoList As Worksheet
Dim ReadingFiles As Boolean     ' to ignore worksheet_change while reading
Dim ToRow As Long
Dim LastRow As Long
Dim rsp
'=============================================================================
'- READ 1 : USERFORM CODE FOR BUTTON 1
'- *READ* FILE PROPERTIES TO WORKSHEET
'=============================================================================
Private Sub CommandButton1_Click()
    Me.Hide
    rsp = MsgBox("Renew the library TABLE ?", vbYesNo, " NEW LIBRARY TABLE")
    If rsp = vbNo Then Exit Sub
    '-------------------------------------------------------------------------
    '- INITIALISE
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' FILESYSTEMOBJECT
    Set ShellObj = CreateObject("Shell.Application")        ' SHELL FOR VOB FILES
    Set MyRegExp = CreateObject("VbScript.RegExp")          ' EXTRACT NUMBER FROM STRING
    Application.Calculation = xlCalculationManual
    '--------------------------------------------------------------------------
    '- set up worksheet
    ReadingFiles = True
    Set VideoList = Worksheets("LIBRARY")
    VideoList.Activate
    With VideoList
        LastRow = .Range("E65536").End(xlUp).Row
        If LastRow > 3 Then .Range("A4:Q" & LastRow).ClearContents
        Application.Goto .Range("A4"), True
    End With
    ToRow = 4
    FileCount = 0
    '---------------------------------------------------------------------------
    '- CALL FILE SUBROUTINE TO GET FILES IN BASE FOLDER
    VideoList.Cells(ToRow, 1).Value = BaseFolder
    ShowFileList (BaseFolder)
    '---------------------------------------------------------------------------
    '- CALL FOLDER SUBROUTINE (WHICH CALLS THE FILE ROUTINE)
    ShowFolderList (BaseFolder)
    '---------------------------------------------------------------------------
    '- FINISH
    MsgBox (FileCount & " files added.")
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    ReadingFiles = False
    Set FSO = Nothing
    Set ShellObj = Nothing
    '---------------------------------------------------------------------------
    Unload Me
End Sub
'========  END OF MAIN ROUTINE =================================================
'===============================================================================
'- READ 2 : SUBROUTINE CALLED FROM READ 1 : GET SUBFOLDERS OF SPECIFIED FOLDER
'===============================================================================
Private Sub ShowFolderList(FolderSpec)
    Dim F, f1, fc, s
    Set F = FSO.GetFolder(FolderSpec)
    Set fc = F.SubFolders
    '--------------------------------------------------------------------------
    On Error GoTo NextFolder
    '---------------------------------------------------------------------------
    '- CHECK SUBFOLDER COUNT
    If fc.Count = 0 Then
        Exit Sub
    Else
        '- LOOP FOLDERS
        For Each f1 In fc
            FolderName = f1.Path
            ShowFileList (FolderName)
            '------------------------------------------------------------------
            '- CALL SELF TO GET ANY SUBFOLDERS IN THIS SUBFOLDER
            ShowFolderList (FolderName)
            '-------------------------------------------------------------------
        Next
    End If
    '---------------------------------------------------------------------------
NextFolder:
End Sub
'-
'===============================================================================
'- READ 3 : SUBROUTINE CALLED FROM READ 2 : TO LIST FILES IN FOLDER
'- This is where the main work is done
'===============================================================================
Private Sub ShowFileList(MyFolder)
    Dim F, f1, fc, Spec
    Set F = FSO.GetFolder(MyFolder)
    Set fc = F.Files
    Dim Ftype As String
    Dim fName As String
    Dim FullName As String
    Dim h, m, s
    '---------------------------------------------------------------------------
    On Error GoTo GetOut
    '- CHECK FILE COUNT
    If fc.Count = 0 Then                        ' empty folder
        Exit Sub
    Else
        '- LOOP FILES
        For Each f1 In fc
            fName = f1.Name         'FSO
            Ftype = UCase(Right(fName, 3))
            Application.StatusBar = FullName
            '--------------------------------------------------------------------
            '- GET FILE DETAILS (ignore Recycle bin files)
            If (Ftype = "AVI" Or Ftype = "VOB" Or Ftype = "WMV" Or Ftype = "MPG") _
                    And InStr(1, MyFolder, "recycle", vbTextCompare) = 0 Then
                FullName = MyFolder & "\" & fName
                Application.StatusBar = FullName
                FileCount = FileCount + 1
                '================================================================
                '- FSO FILE PROPERTIES
                Set Spec = FSO.GetFile(f1)  ' individual file info
                fsoCreated = Spec.DateCreated
                fsoModified = Spec.DateLastModified
                fsoSize = CLng(Spec.Size)
                '----------------------------------------------------------------
                '- GET LAST SUBFOLDER (WHICH CONTAINS THE FILE)
                MySplit = Split(MyFolder, "\", -1, vbTextCompare)
                SubFolder = MySplit(UBound(MySplit))
                '=======================================================================
                '- READ WINDOWS MEDIA PLAYER PROPERTIES                        ' item
                '- Not compatible with VOB files.
                '=======================================================================
                If Ftype <> "VOB" Then
                  WMP.URL = FullName
                  wmpTitle = WMP.currentMedia.getItemInfo("Title")                '40
                  wmpGenre = WMP.currentMedia.getItemInfo("WM/Genre")             '61
                  wmpContent = WMP.currentMedia.getItemInfo("WM/ContentDistributor") '58
                Else
                    wmpTitle = "---"
                    wmpGenre = "---"
                    wmpContent = "---"
                End If
                '====================================================================
                '- READ SHELL PROPERTIES
                '- Reads practically all file types
                '====================================================================
                Set ShellFolder = ShellObj.NameSpace(MyFolder)
                Set ShellFolderItem = ShellFolder.ParseName(fName)
                '--------------------------------------------------------------------
                '- SHELL PROPERTIES USED
                shFrameRate = ShellFolder.GetDetailsOf(ShellFolderItem, 281)
                shFrameHeight = ShellFolder.GetDetailsOf(ShellFolderItem, 280)
                shFrameWidth = ShellFolder.GetDetailsOf(ShellFolderItem, 282)
                shBitrate = ShellFolder.GetDetailsOf(ShellFolderItem, 283)
                shFormat = ShellFolder.GetDetailsOf(ShellFolderItem, 277)
                '-------------------------------------------------------------------
                '- CONVERT DURATION string to Hours, Minutes & Seconds
                shDuration = CStr(ShellFolder.GetDetailsOf(ShellFolderItem, 27))
                If shDuration = "00:00:00" Or shDuration = "" Then
                    shDuration = "-"
                Else
                    h = CInt(Left(shDuration, 2))
                    m = CInt(Mid(shDuration, 4, 2))
                    s = CInt(Right(shDuration, 2))
                    '-
                    h = IIf(h = 0, "", CStr(h) & "h.")
                    m = IIf(m = 0, "", CStr(m) & "m.")
                    s = IIf(s = 0, "", CStr(s) & "s")
                    shDuration = h & m & s
                End If
                '====================================================================
                '- PROPERTIES TO THE WORKSHEET
                '- NB. Some properties do not always exist
                '====================================================================
                With VideoList
                    .Cells(ToRow, "A").Value = wmpTitle
                    .Cells(ToRow, "B").Value = wmpGenre
                    .Cells(ToRow, "C").Value = wmpContent
                    '-------------------------------------
                    .Cells(ToRow, "D").Value = SubFolder
                    .Cells(ToRow, "E").Value = fName
                    .Cells(ToRow, "F").Value = Ftype
                    .Cells(ToRow, "G").Value = shDuration
                    .Cells(ToRow, "H").Value = NumberFromString(shFrameRate)
                    .Cells(ToRow, "I").Value = IIf(shFrameHeight = "", "-", shFrameHeight)
                    .Cells(ToRow, "J").Value = IIf(shFrameWidth = "", "-", shFrameWidth)
                    .Cells(ToRow, "K").Value = fsoCreated
                    .Cells(ToRow, "L").Value = fsoModified
                    .Cells(ToRow, "M").Value = Format((NumberFromString(fsoSize) / 1024000), "###,###.##") & " mb"
                    .Cells(ToRow, "N").Value = IIf(shBitrate = "", "-", shBitrate)
                    .Cells(ToRow, "O").Value = IIf(shFormat = "", "-", shFormat)
                    .Cells(ToRow, "P").Value = " "
                    .Cells(ToRow, "Q").Value = FullName
                End With
                ToRow = ToRow + 1
            End If
            '-------------------------------------------------------------------------
        Next
    End If
    '---------------------------------------------------------------------------------
    Exit Sub
    '=================================================================================
    '- RECORD ERRORS
    '=================================================================================
GetOut:
    If FullName <> "" Then
        MsgBox ("ERROR WITH FILE" & vbCr & FullName & vbCr & "Row : " & ToRow)
        With VideoList
            .Cells(ToRow, "A").Value = "FILE ERROR"
            .Cells(ToRow, "D").Value = SubFolder
            .Cells(ToRow, "E").Value = fName
            .Cells(ToRow, "F").Value = Ftype
            .Cells(ToRow, "Q").Value = FullName
        End With
        ToRow = ToRow + 1
    End If
    '---------------------------------------------------------------------------------
End Sub
'=== END OF READ =====================================================================
'=============================================================================
'- FUNCTION TO EXTRACT A NUMBER FROM A STRING
'=============================================================================
Private Function NumberFromString(OldText)
    Dim NewText As Variant
    With MyRegExp
        .Global = True
        .ignorecase = True
        .Pattern = "[^0-9]"
        NewText = .Replace(OldText, "")
    End With
    NumberFromString = IIf(Trim(NewText) = "", "-", NewText)
End Function
'=============================================================================
'- FORM BUTTON 2 : *WRITE* PROPERTIES TO FILES
'- Looks for "X" in column P for files to change
'- Only changes Title, Genre, & Content Distributor
'=============================================================================
Private Sub CommandButton2_Click()
    Me.Hide
    '-------------------------------------------------------------------------
    '- INITIALISE
    Application.Calculation = xlCalculationManual
    '-------------------------------------------------------------------------
    '- set up worksheet
    Set VideoList = Worksheets("LIBRARY")
    VideoList.Activate
    With VideoList
        LastRow = .Range("E65536").End(xlUp).Row
        '---------------------------------------------------------------------
        '- CHECK IF FILE CHANGES OK
        FileCount = Application.WorksheetFunction.CountIf(.Range("P4:P" & LastRow), "=X")
        If FileCount = 0 Then
            rsp = MsgBox("No changes made")
            Exit Sub
        Else
            rsp = MsgBox("Change " & FileCount & "  files PROPERTIES ?", vbYesNo, " CHANGE FILE PROPERTIES")
            If rsp = vbNo Then Exit Sub
        End If
        '---------------------------------------------------------------------
    End With
    '=========================================================================
    '- CHECK COLUMN P AND WRITE FILE PROPERTY CHANGES
    '=========================================================================
    ReadingFiles = True
    With VideoList
    For ToRow = 4 To LastRow
            If UCase(.Cells(ToRow, "P").Value) = "X" Then
                If .Cells(ToRow, "F").Value = "VOB" Then
                    rsp = MsgBox("Cannot change VOB properties", vbOKCancel)
                    If rsp = vbCancel Then GoTo GetOut
                Else
                    Application.StatusBar = .Cells(ToRow, "E").Value
                    FullName = .Cells(ToRow, "Q").Value
                    Me.WindowsMediaPlayer1.URL = FullName
                    Me.WindowsMediaPlayer1.currentMedia.setItemInfo "Title", .Cells(ToRow, "A").Value
                    WMP.currentMedia.setItemInfo "WM/Genre", .Cells(ToRow, "B").Value
                    WMP.currentMedia.setItemInfo "WM/ContentDistributor", .Cells(ToRow, "C").Value
                End If
                .Cells(ToRow, "P").Value = " "
            End If
            '-----------------------------------------------------------------
    Next
    End With
    '=========================================================================
    '- FINISH WRITING
GetOut:
    MsgBox ("Done")
    Application.Calculation = xlCalculationAutomatic
    Unload Me
End Sub
'=============================================================================
'- FORM BUTTON 3 : EXIT USERFORM
'=============================================================================
Private Sub CommandButton3_Click()
    Unload Me
End Sub
'=============================================================================
'- INITIALISE FORM
'=============================================================================
Private Sub UserForm_Initialize()
    Set WMP = Me.WindowsMediaPlayer1
End Sub
'=============================================================================
'- FORM TERMINATE
'=============================================================================
Private Sub UserForm_Terminate()
    Set WMP = Nothing
    ReadingFiles = False
End Sub

WORKSHEET CODE
Code:
'=====================================================================================
'- 2 WORKSHEET MACROS - COPY/PASTE INTO THE WORKSHEET CODE MODULE
'- Goes into the 'LIBRARY' worksheet module (right click tab & view code)
'- Brian Baulsom June 2010
'=====================================================================================
'=====================================================================================
'- WORKSHEET CHANGE : PUT "X" INTO COLUMN P IF COLUMN A,B, or C CHANGED
'- Handles multiple cells selection
'- 'ReadingFiles' variable is set to True by the READ macro.
'=====================================================================================
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RowCount As Long
    Dim FirstRow As Long
    Dim LastRow As Long
    Dim MyRow As Long
    '---------------------------------------------------------------------------------
    If ReadingFiles = True Then Exit Sub ' .. exit if READ macro is reading files
    '- Safer than setting EnableEvents in case non-standard files cause problems
    '---------------------------------------------------------------------------------
    If Target.Row > 3 And Target.Column < 4 Then
        RowCount = Selection.Cells.Count
        FirstRow = Target.Row
        LastRow = FirstRow + RowCount - 1
        For MyRow = FirstRow To LastRow
            Range("P" & CStr(MyRow)).Value = "X"
        Next
    End If
End Sub
'=========== end of routine ==========================================================
'=====================================================================================
'- DOUBLE CLICK :
'- Column A        : Makes Title = file name without extension
'- Other columns   : Play the file in the required player
'=====================================================================================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Const MyPlayer As String = "E:\Programmes\RealPlayer\RealPlay.exe"
    'Const MyPlayer As String = "C:\Program Files (x86)\Windows Media Player\wmplayer.exe"
    Const MyPlayer As String = "E:\Programmes\VLC Media Player\vlc.exe"
    '---------------------------------------------------------------------------------
    Dim MyFile As String
    Dim ShellString As String
    Dim MyRow As Long
    Quote = Chr(34) ' quotation mark character
    MyRow = Target.Row
    '---------------------------------------------------------------------------------
    If MyRow < 4 Then Beep: Exit Sub
    '---------------------------------------------------------------------------------
    '- TITLE = FILE NAME WITHOUT EXTENSION
    If Target.Column = 1 Then
        F = Cells(MyRow, "E").Value
        Cells(MyRow, 1).Value = Left(F, Len(F) - 4)
        Beep
        Exit Sub
    End If
    '=================================================================================
    '- PLAY THE FILE
    '=================================================================================
    MyFile = Cells(MyRow, "Q").Value
    ShellString = MyPlayer & " " & Quote & MyFile & Quote
    '----------------------------------------------------------------------
    On Error Resume Next
    Beep
    rsp = shell(ShellString, vbNormalFocus)
    If Err.Number <> 0 Then MsgBox ("Play error. Cannot play video file")
    '=================================================================================
End Sub
'=========== end of routine ==========================================================
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
*****************************************************
Revised version.
I have discovered a bug with Media Player which only reads the 'Title' until something is changed in the file. This code Reads and writes the title back again in the first file. It works OK after that.
*****************************************************

Code:
'=============================================================
'- CODE TO RUN THE USERFORM. Cannot declare 'Public' in a form
'- Goes into a standard code module.
'=============================================================
Public ReadingFiles As Boolean
Sub RUN_USERFORM()
    UserForm1.Show
End Sub
'=============================================================


Code:
'=============================================================================
'- VERSION 2 : USERFORM CODE
'- CORRECTS A BUG THAT OCCURS IF READ IS USED IMMEDIATELY EXCEL IS OPENED
'==============================================================================
'- Only 'Title' gets read - not 'Genre' or 'Content'
'- It continues to work correctly one a WRITE is performed, so .....
'- The code re-writes the 'Title' of the first file.
'- Also the ReadingFiles variable should be made Public in the macro sheet
'- that runs the userform as indicated.
'=============================================================================
'- Copy/Paste all this code to a userform
'- Needs 3 buttons & a WindowsMediaPlayer control (set invisible)
'- The READ code does not change files - but test first and use at your own risk
'=============================================================================
'- BUTTON 1 : READ EXTENDED VIDEO FILE PROPERTIES TO A WORKSHEET
'- LISTS ALL AVI/WMV/MPG/VOB FILES IN FOLDERS & SUBFOLDERS OF *BASE FOLDER*
'- Uses WindowsMediaPlayer Control to read the 3 properties that I write to.
'- Uses Shell for ReadOnly properties - it reads practically all file types.
'- NB. Not all properties are the same format, even in the same file type.
'-----------------------------------------------------------------------------
'- BUTTON 2 : WRITES 3 CUSTOM PROPERTIES FROM WORKSHEET COLUMNS A,B,C.
'-----------------------------------------------------------------------------
'- Brian Baulsom June 2010
'=============================================================================
Const BaseFolder As String = "F:\Test"      ' *BASE FOLDER* (no final backslash)
'=============================================================================
'- FileSystemObject
Dim FSO As Object
Dim FolderName As String
Dim FolderPath As String
Dim FolderSpec As String
Dim MyFolder As String
Dim FileCount As Long
'-----------------------------------------
'- PROPERTIES
Dim fsoCreated As Variant   ' file property
Dim fsoModified As Variant  ' file property
Dim fsoSize As Variant      ' file property
Dim MySplit As Variant      ' to get subfolder
Dim SubFolder As String
'-----------------------------------------------------------------------------
'- WINDOWS MEDIA PLAYER PROPERTIES Read/Write (userform control)
Dim WMP As WindowsMediaPlayer
Dim CM As Object
'- CUSTOMISABLE PROPERTIES USED HERE
Dim wmpTitle As String   ' item 40
Dim wmpGenre As String   ' item 61
Dim wmpContent As String ' 58 WM/ContentDistributor = WMP "Content Provider"
'-----------------------------------------------------------------------------
'- SHELL PROPERTIES (Read Only)(WMP does not handle VOB properties very well)
Dim ShellObj As shell
Dim ShellFolder As Folder
Dim ShellFolderItem As FolderItem
'- PROPERTIES                   ' item
Dim shDuration  As Variant      '  27    'Length'
Dim shFrameRate As Variant      ' 281
Dim shFrameHeight As Variant    ' 280
Dim shFrameWidth As Variant     ' 282
Dim shBitrate As Variant        ' 283
Dim shFormat As Variant         ' 277     'Video Compression'
'-----------------------------------------------------------------------------
'- General
Dim FirstFile As Boolean         ' write to first read entry
Dim MyRegExp As Object
Dim VideoList As Worksheet
Dim ToRow As Long
Dim LastRow As Long
Dim rsp
'=============================================================================
'- READ 1 : USERFORM CODE FOR BUTTON 1
'- *READ* FILE PROPERTIES TO WORKSHEET
'=============================================================================
Private Sub CommandButton1_Click()
    Me.Hide
    rsp = MsgBox("Renew the library TABLE ?", vbYesNo, " NEW LIBRARY TABLE")
    If rsp = vbNo Then Exit Sub
    '-------------------------------------------------------------------------
    '- INITIALISE
    FirstFile = True
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' FILE SYSTEM OBJECT
    Set ShellObj = CreateObject("Shell.Application")        ' SHELL FOR STANDARD PROPERTIES
    Set MyRegExp = CreateObject("VbScript.RegExp")          ' EXTRACT NUMBER FROM STRING
    Application.Calculation = xlCalculationManual
    '--------------------------------------------------------------------------
    '- set up worksheet
    ReadingFiles = True
    Set VideoList = Worksheets("LIBRARY")
    VideoList.Activate
    With VideoList
        LastRow = .Range("E65536").End(xlUp).Row
        If LastRow > 3 Then .Range("A4:Q" & LastRow).ClearContents
        Application.Goto .Range("A4"), True
    End With
    ToRow = 4
    FileCount = 0
    '---------------------------------------------------------------------------
    '- CALL FILE SUBROUTINE TO GET FILES IN BASE FOLDER
    VideoList.Cells(ToRow, 1).Value = BaseFolder
    ShowFileList (BaseFolder)
    '---------------------------------------------------------------------------
    '- CALL FOLDER SUBROUTINE (WHICH CALLS THE FILE ROUTINE)
    ShowFolderList (BaseFolder)
    '---------------------------------------------------------------------------
    '- FINISH
    MsgBox (FileCount & " files added.")
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    ReadingFiles = False
    Set FSO = Nothing
    Set ShellObj = Nothing
    '---------------------------------------------------------------------------
    Unload Me
End Sub
'========  END OF MAIN ROUTINE =================================================
'===============================================================================
'- READ 2 : SUBROUTINE CALLED FROM READ 1 : GET SUBFOLDERS OF SPECIFIED FOLDER
'===============================================================================
Private Sub ShowFolderList(FolderSpec)
    Dim F, f1, fc, s
    Set F = FSO.GetFolder(FolderSpec)
    Set fc = F.SubFolders
    '--------------------------------------------------------------------------
    On Error GoTo NextFolder
    '---------------------------------------------------------------------------
    '- CHECK SUBFOLDER COUNT
    If fc.Count = 0 Then
        Exit Sub
    Else
        '- LOOP FOLDERS
        For Each f1 In fc
            FolderName = f1.Path
            ShowFileList (FolderName)
            '------------------------------------------------------------------
            '- CALL SELF TO GET ANY SUBFOLDERS IN THIS SUBFOLDER
            ShowFolderList (FolderName)
            '-------------------------------------------------------------------
        Next
    End If
    '---------------------------------------------------------------------------
NextFolder:
End Sub
'-
'===============================================================================
'- READ 3 : SUBROUTINE CALLED FROM READ 2 : TO LIST FILES IN FOLDER
'- This is where the main work is done
'===============================================================================
Private Sub ShowFileList(MyFolder)
    Dim F, f1, fc, Spec
    Set F = FSO.GetFolder(MyFolder)
    Set fc = F.Files
    Dim Ftype As String
    Dim fName As String
    Dim FullName As String
    Dim h, m, s
    '---------------------------------------------------------------------------
    On Error GoTo GetOut
    '- CHECK FILE COUNT
    If fc.Count = 0 Then                        ' empty folder
        Exit Sub
    Else
        '- LOOP FILES
        For Each f1 In fc
            fName = f1.Name         'FSO
            Ftype = UCase(Right(fName, 3))
            Application.StatusBar = FullName
            '--------------------------------------------------------------------
            '- GET FILE DETAILS (ignore Recycle bin files)
            If (Ftype = "AVI" Or Ftype = "VOB" Or Ftype = "WMV" Or Ftype = "MPG") _
                    And InStr(1, MyFolder, "recycle", vbTextCompare) = 0 Then
                FullName = MyFolder & "\" & fName
                Application.StatusBar = FullName
                FileCount = FileCount + 1
                '================================================================
                '- FSO FILE PROPERTIES
                Set Spec = FSO.GetFile(f1)  ' individual file info
                fsoCreated = Spec.DateCreated
                fsoModified = Spec.DateLastModified
                fsoSize = CLng(Spec.Size)
                '----------------------------------------------------------------
                '- GET LAST SUBFOLDER (WHICH CONTAINS THE FILE)
                MySplit = Split(MyFolder, "\", -1, vbTextCompare)
                SubFolder = MySplit(UBound(MySplit))
                '=======================================================================
                '- READ WINDOWS MEDIA PLAYER PROPERTIES                        ' item
                '- Not compatible with VOB files.
                '=======================================================================
                If Ftype <> "VOB" Then
                  WMP.URL = FullName
                  wmpTitle = WMP.currentMedia.getItemInfo("Title")                '40
                    '-------------------------------------------------------------------
                    '- REF. BUG CORRECTION (RE-WRITE TITLE)
                    If FirstFile = True Then
                        WMP.currentMedia.setItemInfo "Title", wmpTitle
                        FirstFile = False
                    End If
                    '------------------------------------------------------------------
                    wmpGenre = WMP.currentMedia.getItemInfo("WM/Genre")             '61
                    wmpContent = WMP.currentMedia.getItemInfo("WM/ContentDistributor") '58
                Else
                    wmpTitle = "---"
                    wmpGenre = "---"
                    wmpContent = "---"
                End If
                '=======================================================================
                '- READ SHELL PROPERTIES
                '- Reads practically all file types
                '====================================================================
                Set ShellFolder = ShellObj.NameSpace(MyFolder)
                Set ShellFolderItem = ShellFolder.ParseName(fName)
                '--------------------------------------------------------------------
                '- SHELL PROPERTIES USED
                shFrameRate = ShellFolder.GetDetailsOf(ShellFolderItem, 281)
                shFrameHeight = ShellFolder.GetDetailsOf(ShellFolderItem, 280)
                shFrameWidth = ShellFolder.GetDetailsOf(ShellFolderItem, 282)
                shBitrate = ShellFolder.GetDetailsOf(ShellFolderItem, 283)
                shFormat = ShellFolder.GetDetailsOf(ShellFolderItem, 277)
                '-------------------------------------------------------------------
                '- CONVERT DURATION string to Hours, Minutes & Seconds
                shDuration = CStr(ShellFolder.GetDetailsOf(ShellFolderItem, 27))
                If shDuration = "00:00:00" Or shDuration = "" Then
                    shDuration = "-"
                Else
                    h = CInt(Left(shDuration, 2))
                    m = CInt(Mid(shDuration, 4, 2))
                    s = CInt(Right(shDuration, 2))
                    '-
                    h = IIf(h = 0, "", CStr(h) & "h.")
                    m = IIf(m = 0, "", CStr(m) & "m.")
                    s = IIf(s = 0, "", CStr(s) & "s")
                    shDuration = h & m & s
                End If
                '====================================================================
                '- PROPERTIES TO THE WORKSHEET
                '- NB. Some properties do not always exist
                '====================================================================
                With VideoList
                    .Cells(ToRow, "A").Value = wmpTitle
                    .Cells(ToRow, "B").Value = wmpGenre
                    .Cells(ToRow, "C").Value = wmpContent
                    '-------------------------------------
                    .Cells(ToRow, "D").Value = SubFolder
                    .Cells(ToRow, "E").Value = fName
                    .Cells(ToRow, "F").Value = Ftype
                    .Cells(ToRow, "G").Value = shDuration
                    .Cells(ToRow, "H").Value = NumberFromString(shFrameRate)
                    .Cells(ToRow, "I").Value = IIf(shFrameHeight = "", "-", shFrameHeight)
                    .Cells(ToRow, "J").Value = IIf(shFrameWidth = "", "-", shFrameWidth)
                    .Cells(ToRow, "K").Value = fsoCreated
                    .Cells(ToRow, "L").Value = fsoModified
                    .Cells(ToRow, "M").Value = Format((NumberFromString(fsoSize) / 1024000), "###,###.##") & " mb"
                    .Cells(ToRow, "N").Value = IIf(shBitrate = "", "-", shBitrate)
                    .Cells(ToRow, "O").Value = IIf(shFormat = "", "-", shFormat)
                    .Cells(ToRow, "P").Value = " "
                    .Cells(ToRow, "Q").Value = FullName
                End With
                ToRow = ToRow + 1
            End If
            '-------------------------------------------------------------------------
        Next
    End If
    '---------------------------------------------------------------------------------
    Exit Sub
    '=================================================================================
    '- RECORD ERRORS
    '=================================================================================
GetOut:
    If FullName <> "" Then
        MsgBox ("ERROR WITH FILE" & vbCr & FullName & vbCr & "Row : " & ToRow)
        With VideoList
            .Cells(ToRow, "A").Value = "FILE ERROR"
            .Cells(ToRow, "D").Value = SubFolder
            .Cells(ToRow, "E").Value = fName
            .Cells(ToRow, "F").Value = Ftype
            .Cells(ToRow, "Q").Value = FullName
        End With
        ToRow = ToRow + 1
    End If
    '---------------------------------------------------------------------------------
End Sub
'=== END OF READ =====================================================================
'=============================================================================
'- FUNCTION TO EXTRACT A NUMBER FROM A STRING
'=============================================================================
Private Function NumberFromString(OldText)
    Dim NewText As Variant
    With MyRegExp
        .Global = True
        .ignorecase = True
        .Pattern = "[^0-9]"
        NewText = .Replace(OldText, "")
    End With
    NumberFromString = IIf(Trim(NewText) = "", "-", NewText)
End Function
'=============================================================================
'- FORM BUTTON 2 : *WRITE* PROPERTIES TO FILES
'- Looks for "X" in column P for files to change
'- Only changes Title, Genre, & Content Distributor
'=============================================================================
Private Sub CommandButton2_Click()
    Me.Hide
    '-------------------------------------------------------------------------
    '- INITIALISE
    Application.Calculation = xlCalculationManual
    '-------------------------------------------------------------------------
    '- set up worksheet
    Set VideoList = Worksheets("LIBRARY")
    VideoList.Activate
    With VideoList
        LastRow = .Range("E65536").End(xlUp).Row
        '---------------------------------------------------------------------
        '- CHECK IF FILE CHANGES OK
        FileCount = Application.WorksheetFunction.CountIf(.Range("P4:P" & LastRow), "=X")
        If FileCount = 0 Then
            rsp = MsgBox("No changes made")
            Exit Sub
        Else
            rsp = MsgBox("Change " & FileCount & "  files PROPERTIES ?", vbYesNo, " CHANGE FILE PROPERTIES")
            If rsp = vbNo Then Exit Sub
        End If
        '---------------------------------------------------------------------
    End With
    '=========================================================================
    '- CHECK COLUMN P AND WRITE FILE PROPERTY CHANGES
    '=========================================================================
    ReadingFiles = True
    With VideoList
    For ToRow = 4 To LastRow
            If UCase(.Cells(ToRow, "P").Value) = "X" Then
                If .Cells(ToRow, "F").Value = "VOB" Then
                    rsp = MsgBox("Cannot change VOB properties", vbOKCancel)
                    If rsp = vbCancel Then GoTo GetOut
                Else
                    Application.StatusBar = .Cells(ToRow, "E").Value
                    FullName = .Cells(ToRow, "Q").Value
                    WMP.URL = FullName
                    WMP.currentMedia.setItemInfo "Title", .Cells(ToRow, "A").Value
                    WMP.currentMedia.setItemInfo "WM/Genre", .Cells(ToRow, "B").Value
                    WMP.currentMedia.setItemInfo "WM/ContentDistributor", .Cells(ToRow, "C").Value
                End If
                .Cells(ToRow, "P").Value = " "
            End If
            '-----------------------------------------------------------------
    Next
    End With
    '=========================================================================
    '- FINISH WRITING
GetOut:
    MsgBox ("Done")
    Application.Calculation = xlCalculationAutomatic
    Unload Me
End Sub
'=============================================================================
'- FORM BUTTON 3 : EXIT USERFORM
'=============================================================================
Private Sub CommandButton3_Click()
    Unload Me
End Sub
'=============================================================================
'- INITIALISE FORM
'=============================================================================
Private Sub UserForm_Initialize()
    Set WMP = Me.WindowsMediaPlayer1
    Set CM = Me.WindowsMediaPlayer1.currentMedia
End Sub
'=============================================================================
'- FORM TERMINATE
'=============================================================================
Private Sub UserForm_Terminate()
    Set WMP = Nothing
    ReadingFiles = False
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,114,236
Messages
5,546,672
Members
410,753
Latest member
Ian R
Top