'============================================================================================================
'- READ .MP3 & .WMA FILE PROPERTIES TO A WORKSHEET
'============================================================================================================
'- MACRO TO :-
'- *1. SELECT A FOLDER - *2. CLEAR THE ACTIVE WORKSHEET* - *3. READ .MP3 & .WMA EXTENDED FILE PROPERTIES*
'- *3. MAKES PROPERTY CELLS BLUE
'- ONLY EXTRACTS FILE DATA SO CAN BE USED ON ITS OWN. SHEETS CAN BE SAVED AS NORMAL
'- CAN THEN RUN MACRO "WRITE_TO_EXPLORER" (in another module below) TO *CHANGE* PROPERTIES
'- Uses Windows Shell32.dll (Requires Tools/References .. 'Microsoft Shell Controls And Automation')
'- Brian Baulsom July 2007 - using Excel 2000/Windows XP
' ==========================================================================================================
'- Method (works on all files in a single folder)
'- 1. Run macro "READ_FROM_EXPLORER" below TO GET FILE NAMES INTO CURRENTLY ACTIVE WORKSHEET
'- 2. Manually amend file details in the worksheet.Delete or hide rows for files not changed saves time(can be left)
'- 3. Run macro "WRITE_TO_EXPLORER" (other module)
'===========================================================================================================
Option Base 1 ' MyProperties(15) starts 1 instead of 0
Dim MyFilePathName As String ' Local variable full path & file name
Public MyPathName As String ' **Public variable |enables 'Sub GetPathFileNameFromFullPath()'|
Public MyFileName As String ' **Public variable |usage in 'WRITE_TO_EXPLORER' macro |
'- Properties Array (list of integers)
Dim Arr1 As Variant ' "Name"= shell property zero + First 5 properties in Windows Explorer
Dim Arr2 As Variant ' some more shell GetDetailsOf() property numbers (0-34 available. 3 unused)
Dim MyProperties(16) As Integer ' Shell property index numbers used here. Puts them in required order
Dim MyPropertyNum As Integer ' Array item position 1-15
Dim MyPropertyVal As Variant ' Lookup Array data shell property numbers 0,16, 17 ... etc.
'-
Dim ws As Worksheet
Dim ToRow As Long ' write to worksheet row number
'- Shell variables
Dim ShellObj As Shell
Dim MyFolder As Folder
Dim MyFolderItem As FolderItem
'-
'===========================================================================================================
'- MAIN ROUTINE
'===========================================================================================================
Sub READ_FROM_EXPLORER()
Application.EnableEvents = False ' WORKSHEET Worksheet_Change() makes changed cells yellow
'-------------------------------------------------------------------------------------------------------
'- GET FOLDER NAME FROM FIRST FOLDER\FILE IN THE WORKSHEET
MyFilePathName = ActiveSheet.Range("O2").Value
If InStr(1, MyFilePathName, "\", vbTextCompare) <> 0 Then 'there is "\" in the path
GetPathFileNameFromFullPath (MyFilePathName) ' PUBLIC SUBROUTINE IN 'READ_FROM_EXPLORER' module
ChDrive MyPathName
ChDir MyPathName & "\"
Else
ChDrive ThisWorkbook.FullName
ChDir ThisWorkbook.FullName
End If
'- GET FOLDER - Method 1 - using Windows Dialog (comment out if not required)
'MsgBox ("Selecting a single file in the following dialog gets the required *FOLDER*." & vbCr & vbCr _
& "NB. CLEARS THE CURRENTLY ACTIVE SHEET.")
MyFilePathName = _
Application.GetOpenFilename("Audio Files (*.mp3;*.wma),*.mp3;*.wma", , " GET FOLDER REQUIRED")
If MyFilePathName = "False" Then Exit Sub
GetPathFileNameFromFullPath MyFilePathName ' subroutine to separate folder & file name
'-------------------------------------------------------------------------------------------------------
' '- GET FOLDER - Method 2 - hard coded for testing (comment out if not required)
' MyPathName = "C:\TEMP\MP3_TEST" ' SET AS REQUIRED
'=======================================================================================================
Set ShellObj = New Shell
Set MyFolder = ShellObj.NameSpace(MyPathName)
'------------------------------------------------------------------------------------------
ChDrive MyPathName
ChDir MyPathName & "\"
Set ws = ActiveSheet
ToRow = 2
With ws.Columns("A:O").Cells
.ClearContents ' clear worksheet
.Interior.ColorIndex = xlNone
End With
ws.Rows.Hidden = False
'-------------------------------------------------------------------------------------------
'- INITIALISE PROPERTY ARRAY. CLEAR & SET UP WORKSHEET
'- Set up array to sort properties into the required order
'- do not change Arr1 (list of changeable fields in Windows Explorer - used in WRITE macro.)
' "Name", "Artist", "Album", "Year", "Track", "Genre", "Lyrics", "Title","Comments")
Arr1 = Array(0, 16, 17, 18, 19, 20, 27, 10, 14)
For n = 1 To 9: MyProperties(n) = Arr1(n): Next
'- "Duration", "Size", "Date Modified", "Category", "Author", "Bit Rate"
Arr2 = Array(21, 9, 12, 3, 1, 22, 33)
For n = 10 To 16: MyProperties(n) = Arr2(n - 9): Next
'-------------------------------------------------------------------------------------------
'- write worksheet header
For n = 1 To 14
ws.Cells(1, n).Value = MyFolder.GetDetailsOf(MyFolder.Items, MyProperties(n))
Next
With ws
'- "Lyrics" is not included in the Shell properties. I have used a blank one item 27
.Cells(1, "G").Value = "Lyrics"
'- This is useful for other purposes. eg. to play the track via macro.
.Cells(1, "O").Value = "Full Name"
.Range("A1:O1").Interior.ColorIndex = 37 ' Dark blue header
End With
'===========================================================================================
'- GET FILE NAMES & PROPERTIES FROM FOLDER
'===========================================================================================
MyFileName = Dir(mypath & "*.*") 'first file name
Do While MyFileName <> ""
'- filter .MP3 & .WMA
If UCase(Right(MyFileName, 3)) = "MP3" Or UCase(Right(MyFileName, 3)) = "WMA" Then
Set MyFolderItem = MyFolder.ParseName(MyFileName)
'--------------------------------------------------------------------
'- properties to worksheet
For MyPropertyNum = 1 To 14
MyPropertyVal = MyFolder.GetDetailsOf(MyFolderItem, MyProperties(MyPropertyNum))
ws.Cells(ToRow, MyPropertyNum).Value = MyPropertyVal
Next
'---------------------------------------------------------------------
'- add full path\file name (used as lookup by "WRITE_TO_EXPLORER")
ws.Cells(ToRow, 15).Value = MyPathName & "\" & MyFileName
ToRow = ToRow + 1
End If
MyFileName = Dir ' Get next file name
Loop
'-------------------------------------------------------------------------------------------
'- finish
With ws
.Activate
'.UsedRange.Columns.AutoFit
.Range("D1,G1,I1,K1").EntireColumn.Hidden = True
.Range("A1").Select
End With
'-------------------------------------------------------------------------------------------
'- colour editable range -> blue
'-------------------------------------------------------------------------------------------
If ToRow > 2 Then ws.Range("B2:I" & ws.Range("A2").End(xlDown).Row).Interior.ColorIndex = 34
MsgBox ("Done.")
Application.EnableEvents = True
End Sub
'=========== END OF MAIN ROUTINE ===============================================================
'===============================================================================================
'- SUB TO SEPARATE PATH & FILE NAME FROM FULL NAME
'- puts to Public module level variables 'MyFileName' & 'MyPathName'
'===============================================================================================
Public Sub GetPathFileNameFromFullPath(Nm As String)
For c = Len(Nm) To 1 Step -1
If Mid(Nm, c, 1) = "\" Then
MyFileName = Right(Nm, Len(Nm) - c)
MyPathName = Left(Nm, Len(Nm) - Len(MyFileName) - 1)
Exit Sub
End If
Next
End Sub
'----------------------------------------------------------------------------------------------
