Albert
08-30-2005, 02:08 PM
Hi Friends,
I am trying to use Excel-VBA to Display - Edit - Save back the ID3V2 File Properties of my MP3 files collection
Here till now, I was able to Display the Properties, but I want to Save the Edited or updated ID3V2 properties back to the each MP3 file, Can some one help me to do this by giving the Subroutine to save the properties on clicking the Excel Sheet "Save" feature?
For your reference, I am including the existing code here
Thanks in advance,
Al
Code in the Module1
Option Explicit
'Requires a reference to:
' Microsoft Shell Controls and Automation (shell32.dll)
'Uses techniques found here:
'http://www.microsoft.com/resources/documentation/windows/2000/server/scriptguide/en-us/sas_fil_lunl.mspx
Public objShell As IShellDispatch4
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Type MP3Tag
ID As String * 3
Title As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 28
ID3Tag As Byte
TrackNumber As Byte
End Type
Sub DisplayMP3Info()
Dim i As Long
Dim Folder As String
Dim StrLen As Long, FolderLen As Long
Dim NameOnly As String
Dim Row As Long
' Prompt for the directory
Folder = GetDirectory("Select a directory that has MP3 files")
Set objShell = CreateObject("Shell.Application")
FolderLen = Len(Folder)
With Application.FileSearch
.NewSearch
.LookIn = Folder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
If .FoundFiles.Count = 0 Then
MsgBox "Error - No files.", vbCritical
GoTo ExitSub
Exit Sub
End If
Row = 1
Worksheets("Sheet1").Activate
ActiveSheet.Cells.Clear
With ActiveSheet.Range("A1:K1")
.Value = Array("Path", "Filename", "Size", "Date/Time", "Artist", "Album Title", "Year", "Track No.", "Genre", "Duration", "Bit Rate")
.Font.Bold = True
End With
Application.ScreenUpdating = False
For i = 1 To .FoundFiles.Count
If i Mod (100) = 0 Then
DoEvents
Application.StatusBar = "Working on " & i & " of " & .FoundFiles.Count
End If
If Right(.FoundFiles(i), 3) = "mp3" Then
Row = Row + 1
'Parse the directory path to get genre, artist, and album name, and song title
ActiveSheet.Cells(Row, 1) = .FoundFiles(i)
ActiveSheet.Cells(Row, 2) = FileNameOnly(.FoundFiles(i))
ActiveSheet.Cells(Row, 3) = FileLen(.FoundFiles(i)) ' file size
ActiveSheet.Cells(Row, 4) = FileDateTime(.FoundFiles(i)) 'date
ActiveSheet.Cells(Row, 5) = GetMP3TagInfo(.FoundFiles(i), 16) 'artist
ActiveSheet.Cells(Row, 6) = GetMP3TagInfo(.FoundFiles(i), 17) 'album title
ActiveSheet.Cells(Row, 7) = GetMP3TagInfo(.FoundFiles(i), 18) 'year
ActiveSheet.Cells(Row, 8) = GetMP3TagInfo(.FoundFiles(i), 19) 'track number
ActiveSheet.Cells(Row, 9) = GetMP3TagInfo(.FoundFiles(i), 20) 'duration
ActiveSheet.Cells(Row, 10) = GetMP3TagInfo(.FoundFiles(i), 21) 'genre
ActiveSheet.Cells(Row, 11) = GetMP3TagInfo(.FoundFiles(i), 22) 'bit rate
End If
Next i
End If
End With
ExitSub:
'update the pivot table
ActiveSheet.UsedRange.Name = "Data"
Worksheets("pivot").PivotTables("PivotTable1").PivotCache.Refresh
Set objShell = Nothing
Application.StatusBar = False
End Sub
Function GetMP3TagInfo(FolderName, ItemNum)
Dim strFilename
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Dim FileName As String
FileName = FileNameOnly(FolderName)
Set objFolder = objShell.Namespace(Left(FolderName, Len(FolderName) - Len(FileName)))
Set objFolderItem = objFolder.ParseName(FileName)
GetMP3TagInfo = objFolder.GetDetailsOf(objFolderItem, ItemNum)
End Function
Function FileNameOnly(FullPath) As String
Dim i As Long
Dim FN As String
If Right(FullPath, 1) = "\" Then FullPath = Left(FullPath, Len(FullPath) - 1)
For i = Len(FullPath) To 1 Step -1
If Mid(FullPath, i, 1) = "\" Then
FileNameOnly = FN
Exit Function
Else
FN = Mid(FullPath, i, 1) & FN
End If
Next i
End Function
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub mySub()
MsgBox "I want to save the files on the click of this SAVE"
'Please include the code to save each Mp3 file in the file
End Sub
Code in This Workbook Object
Private Sub Workbook_BeforeSave _
(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call mySub
'strFile = ActiveSheet.Cells(2, 1) 'Filename of mp3
'MsgBox "I am " & strFile
'lngFileLen = FileLen(strFile)
'intFF = FreeFile
'Open strFile For Binary Access Write As intFF
'Tag.Title = ActiveCell.Offset(0, 3)
'Tag.Artist = ActiveCell.Offset(0, 4)
'Tag.Album = ActiveCell.Offset(0, 5)
'Tag.Year = ActiveCell.Offset(0, 6)
'Tag.Comment = ActiveCell.Offset(0, 7)
'Tag.TrackNumber = ActiveCell.Offset(0, 8)
'Put intFF, lngFileLen - cRecordLen + 1, Tag
'Debug.Print Tag.Title; 'check if the info is updated
'Close intFF
End Sub
I am trying to use Excel-VBA to Display - Edit - Save back the ID3V2 File Properties of my MP3 files collection
Here till now, I was able to Display the Properties, but I want to Save the Edited or updated ID3V2 properties back to the each MP3 file, Can some one help me to do this by giving the Subroutine to save the properties on clicking the Excel Sheet "Save" feature?
For your reference, I am including the existing code here
Thanks in advance,
Al
Code in the Module1
Option Explicit
'Requires a reference to:
' Microsoft Shell Controls and Automation (shell32.dll)
'Uses techniques found here:
'http://www.microsoft.com/resources/documentation/windows/2000/server/scriptguide/en-us/sas_fil_lunl.mspx
Public objShell As IShellDispatch4
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Type MP3Tag
ID As String * 3
Title As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 28
ID3Tag As Byte
TrackNumber As Byte
End Type
Sub DisplayMP3Info()
Dim i As Long
Dim Folder As String
Dim StrLen As Long, FolderLen As Long
Dim NameOnly As String
Dim Row As Long
' Prompt for the directory
Folder = GetDirectory("Select a directory that has MP3 files")
Set objShell = CreateObject("Shell.Application")
FolderLen = Len(Folder)
With Application.FileSearch
.NewSearch
.LookIn = Folder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
If .FoundFiles.Count = 0 Then
MsgBox "Error - No files.", vbCritical
GoTo ExitSub
Exit Sub
End If
Row = 1
Worksheets("Sheet1").Activate
ActiveSheet.Cells.Clear
With ActiveSheet.Range("A1:K1")
.Value = Array("Path", "Filename", "Size", "Date/Time", "Artist", "Album Title", "Year", "Track No.", "Genre", "Duration", "Bit Rate")
.Font.Bold = True
End With
Application.ScreenUpdating = False
For i = 1 To .FoundFiles.Count
If i Mod (100) = 0 Then
DoEvents
Application.StatusBar = "Working on " & i & " of " & .FoundFiles.Count
End If
If Right(.FoundFiles(i), 3) = "mp3" Then
Row = Row + 1
'Parse the directory path to get genre, artist, and album name, and song title
ActiveSheet.Cells(Row, 1) = .FoundFiles(i)
ActiveSheet.Cells(Row, 2) = FileNameOnly(.FoundFiles(i))
ActiveSheet.Cells(Row, 3) = FileLen(.FoundFiles(i)) ' file size
ActiveSheet.Cells(Row, 4) = FileDateTime(.FoundFiles(i)) 'date
ActiveSheet.Cells(Row, 5) = GetMP3TagInfo(.FoundFiles(i), 16) 'artist
ActiveSheet.Cells(Row, 6) = GetMP3TagInfo(.FoundFiles(i), 17) 'album title
ActiveSheet.Cells(Row, 7) = GetMP3TagInfo(.FoundFiles(i), 18) 'year
ActiveSheet.Cells(Row, 8) = GetMP3TagInfo(.FoundFiles(i), 19) 'track number
ActiveSheet.Cells(Row, 9) = GetMP3TagInfo(.FoundFiles(i), 20) 'duration
ActiveSheet.Cells(Row, 10) = GetMP3TagInfo(.FoundFiles(i), 21) 'genre
ActiveSheet.Cells(Row, 11) = GetMP3TagInfo(.FoundFiles(i), 22) 'bit rate
End If
Next i
End If
End With
ExitSub:
'update the pivot table
ActiveSheet.UsedRange.Name = "Data"
Worksheets("pivot").PivotTables("PivotTable1").PivotCache.Refresh
Set objShell = Nothing
Application.StatusBar = False
End Sub
Function GetMP3TagInfo(FolderName, ItemNum)
Dim strFilename
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Dim FileName As String
FileName = FileNameOnly(FolderName)
Set objFolder = objShell.Namespace(Left(FolderName, Len(FolderName) - Len(FileName)))
Set objFolderItem = objFolder.ParseName(FileName)
GetMP3TagInfo = objFolder.GetDetailsOf(objFolderItem, ItemNum)
End Function
Function FileNameOnly(FullPath) As String
Dim i As Long
Dim FN As String
If Right(FullPath, 1) = "\" Then FullPath = Left(FullPath, Len(FullPath) - 1)
For i = Len(FullPath) To 1 Step -1
If Mid(FullPath, i, 1) = "\" Then
FileNameOnly = FN
Exit Function
Else
FN = Mid(FullPath, i, 1) & FN
End If
Next i
End Function
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub mySub()
MsgBox "I want to save the files on the click of this SAVE"
'Please include the code to save each Mp3 file in the file
End Sub
Code in This Workbook Object
Private Sub Workbook_BeforeSave _
(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call mySub
'strFile = ActiveSheet.Cells(2, 1) 'Filename of mp3
'MsgBox "I am " & strFile
'lngFileLen = FileLen(strFile)
'intFF = FreeFile
'Open strFile For Binary Access Write As intFF
'Tag.Title = ActiveCell.Offset(0, 3)
'Tag.Artist = ActiveCell.Offset(0, 4)
'Tag.Album = ActiveCell.Offset(0, 5)
'Tag.Year = ActiveCell.Offset(0, 6)
'Tag.Comment = ActiveCell.Offset(0, 7)
'Tag.TrackNumber = ActiveCell.Offset(0, 8)
'Put intFF, lngFileLen - cRecordLen + 1, Tag
'Debug.Print Tag.Title; 'check if the info is updated
'Close intFF
End Sub