'===============================================================================
=============================
'- READ .MP3 & .WMA FILE PROPERTIES TO A WORKSHEET
'===============================================================================
=============================
'- MACRO TO :'- *1. SELECT A FOLDER - *2. CLEAR THE ACTIVE WORKSHEET* - *3. READ .MP3 & .W
MA EXTENDED FILE PROPERTIES*
'- *3. MAKES PROPERTY CELLS BLUE
'- ONLY EXTRACTS FILE DATA SO CAN BE USED ON ITS OWN. SHEETS CAN BE SAVED AS NOR
MAL
'- CAN THEN RUN MACRO "WRITE_TO_EXPLORER" (in another module below) TO *CHANGE*
PROPERTIES
'- Uses Windows Shell32.dll (Requires Tools/References .. 'Microsoft Shell Contr
ols 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 ACTI
VE 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 GetPat
hFileNameFromFullPath()'|
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 prop
erties in Windows Explorer
Dim Arr2 As Variant
' some more shell GetDetailsOf() property nu
mbers (0-34 available. 3 unused)
Dim MyProperties(16) As Integer
' Shell property index numbers used here. Pu
ts 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 cha
nged 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 t
he 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 requi
red)
'
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, MyPropertie
s(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
'---------------------------------------------------------------------------------------------
