Hi all,

Just wanted to share a class I put together using various scripts
found online that I customized to work cleaner by encapsulating
redundant code into functions. I also modifed the scripts where there
was sloppy or unhandled coding causing errors. Put all that together
and what you have below is nowhere near the scripts I started with.
Oh yeah...

This class is for reading ID3v2 tags from MP3 files into an array that
can then be dumped to an Excel spreadsheet (for example) or any other
writeable format you choose. It's purpose, of course, is mainly for
quickly cataloging your MP3 collections in Excel, which can in turn be
imported into Access if you wanted to. It's intended to be used in
Excel so I take no fault if it doesn't work outside of that
environment. If you have any questions, feel free to email me
directly as I don't always have time to monitor my newsgroup posts.
crferguson addtheatsymbol gmail dot com.

==============================
Option Explicit

Private bTemp As Byte, bVersion As Byte
Private sTags As String

'field names
Private TitleField As String
Private ArtistField As String
Private AlbumField As String
Private YearField As String
Private GenreField As String
Private FieldSize As Long
Private SizeOffset As Long
Private FieldOffset As Long
Private TrackNbr As String
Private SituationField As String

Private arrTags(1 To 6, 1 To 2), arrFields(1 To 8)

Public Function GetID3v2Tags(ByVal FileName As String) As Variant
On Error GoTo SendError

Dim iFN As Integer
Dim lHeaderPos As Long
Dim lFileSize As Long

arrTags(1, 1) = "Title"
arrTags(2, 1) = "Artist"
arrTags(3, 1) = "Album"
arrTags(4, 1) = "Year"
arrTags(5, 1) = "Genre"
arrTags(6, 1) = "Track #"

iFN = FreeFile
Open FileName For Binary As iFN
lFileSize = LOF(iFN)

'Check for a Header
Get iFN, 1, bTemp

If bTemp < 255 And bTemp < 73 Then
Exit Function
End If

lHeaderPos = 1
Get iFN, 2, bTemp
If Not (bTemp = 250 Or bTemp = 251) Then
If bTemp = 68 Then
Get iFN, 3, bTemp
If bTemp = 51 Then
Dim lX As Currency
Get iFN, 4, bVersion
Get iFN, 7, bTemp
lX = bTemp * 20917152
Get iFN, 8, bTemp
lX = lX + (CLng(bTemp) * 16384)
Get iFN, 9, bTemp
lX = lX + (bTemp * 128)
Get iFN, 10, bTemp
lX = lX + bTemp
If (lX lFileSize Or lX 2147483647) Then
Exit Function
End If
sTags = Space$(lX)
Get iFN, 11, sTags
lHeaderPos = lX + 11
End If
End If
End If

If Not sTags = "" Then
ParseTags
GetID3v2Tags = arrTags
End If

ClearObjects:
Close iFN
Erase arrTags
Exit Function

SendError:
Dim sMsg As String
sMsg = "An error occured in GetID3v2Tags:" & vbNewLine & vbNewLine
& _
"File: " & FileName & vbNewLine & _
"Error Number: " & Err.Number & vbNewLine & _
"Description: " & Err.Description
Debug.Print sMsg
Err.Clear
GoTo ClearObjects
End Function

Private Sub ParseTags()
On Error GoTo SendError

Dim dX As Double

SetFieldNames bVersion

For dX = 1 To 6
arrTags(dX, 2) = GetAttribute(arrFields(dX))
Next

ClearObjects:
Exit Sub

SendError:
MsgBox "An error occured in ParseTags:" & vbNewLine & vbNewLine &
_
"Error Number: " & Err.Number & vbNewLine & _
"Description: " & Err.Description
Err.Clear
GoTo ClearObjects
End Sub

Private Sub SetFieldNames(ByVal Version)
Select Case Version
Case 2 'ID3v2.2
arrFields(1) = "TT2" 'title field
arrFields(2) = "TOA" 'artist field
arrFields(3) = "TAL" 'album field
arrFields(4) = "TYE" 'year field
arrFields(5) = "TCO" 'genre field
arrFields(6) = "TRCK" 'track number
FieldOffset = 7 'fieldoffset
SizeOffset = 5 'size of offset
Case 3 'ID3v2.3
arrFields(1) = "TIT2" 'title field
arrFields(2) = "TPE1" 'artist field
arrFields(3) = "TALB" 'album field
arrFields(4) = "TYER" 'year field
arrFields(5) = "TCON" 'genre field
arrFields(6) = "TRCK" 'track number
FieldOffset = 11 'fieldoffset
SizeOffset = 7 'size of offset
Case Else
Exit Sub
End Select
End Sub

Private Function GetAttribute(ByVal AttributeName As String) As String
Dim dX As Double, sTemp As String

dX = InStr(sTags, AttributeName)
If dX 0 Then
'read the attribute
FieldSize = Asc(Mid(sTags, dX + SizeOffset)) - 1
If bVersion = 3 Then
'check for compressed or encrypted field
bTemp = Asc(Mid(sTags, dX + 9))
If (bTemp And 128) = 128 Or (bTemp And 64) = 64 Then
GetAttribute = ""
End If
End If
sTemp = Mid(sTags, dX + FieldOffset, FieldSize)

'check if parsing genre tag
If Mid(AttributeName, 1, 3) = "TCO" Then
If Left$(sTemp, 1) = "(" Then
sTemp = Val(Mid$(sTemp, 2, 2))
End If
End If

'set resulting attribute value
GetAttribute = sTemp
End If
End Function

'Private Sub Usage()
' 'this sub is just a sample on how to use the
' 'ID3 tag reading class. The ID3 reader class
' 'returns an array of the tags to a variant variable.
' 'This assumes you named your class module "ID3v2Reader"
'
' Dim ir As ID3v2Reader
' Dim vTemp As Variant
'
' Set ir = New ID3v2Reader
' vTemp = ir.GetID3v2Tags("C:\MyFile.mp3")
'
'End Sub
==================================

Hope this helps someone. I found it difficult to find good info on
doing this in VBA. Also, I developed this on Windows Vista / Office
2007, but I'm fairly certain there's nothing in it that would cause a
problem in previous versions.

Thanks,

Cory