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).
WORKSHEET CODE
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 SubWORKSHEET 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 ==========================================================
