codice:
'Autore: Matteo Freddi
'per informazioni, contattatemi a mattytr@tiscalinet.it
'se usate questo codice nei vostri programmi, gradirei essere ricordato.
'
'Le informazioni che ho utilizzato sono dipsonibili a questi indirizzi
'http://www.dv.co.yu/mpgscript/mpeghdr.htm
'http://www.mp3-tech.org/
Type Mp3Header
MpegVer As Byte
Layer As Byte
CRC As Byte '0=presente
BitRate As Integer
Frames As Long
Sample As Long
ChannelMode As String
CopyRight As Byte
Original As Byte
ByteLen As Long
End Type
Type Mp3Info
FileLength As Long
MpegVer As Byte
Layer As Byte
CRC As Byte '0=presente
BitRate As Integer
Frames As Long
CBR As Boolean
Sample As Long
ChannelMode As Byte 'per informazioni testuali, richiamare la funzione ChannelMode
CopyRight As Byte
Original As Byte
Sec As Integer
ID3 As Boolean
Titolo As String '* 30
Autore As String '* 30
Album As String '* 30
Anno As String '* 4
Commento As String '* 29
Traccia As Byte
Genere As Byte
End Type
Const BitSum As Byte = 2 ^ 7 + 2 ^ 6 + 2 ^ 5 + 2 ^ 4
Dim FFile As Byte
Sub ReadID3(Mp3 As Mp3Info)
Dim lf As Long
Dim TAG As String * 3
Dim TmpS As String
' Prendo la lunghezza del file e ci sottraggo 127 per potermi posizionare al punto giusto del file
If Mp3.FileLength < 128 Then Exit Sub
' controllo che esistano le info ID3
lf = Mp3.FileLength - 127
Seek #FFile, lf
Get #FFile, , TAG
If TAG <> "TAG" Then Exit Sub
' Il tag ID3 esiste e quindi carico i dati
TmpS = Space(30)
Get #FFile, , TmpS
Mp3.Titolo = DeleteZero(TmpS)
TmpS = Space(30)
Get #FFile, , TmpS
Mp3.Autore = DeleteZero(TmpS)
TmpS = Space(30)
Get #FFile, , TmpS
Mp3.Album = DeleteZero(TmpS)
TmpS = Space(4)
Get #FFile, , TmpS
Mp3.Anno = DeleteZero(TmpS)
TmpS = Space(29)
Get #FFile, , TmpS
Mp3.Commento = DeleteZero(TmpS)
Get #FFile, , Mp3.Traccia
Get #FFile, , Mp3.Genere
Mp3.ID3 = True
End Sub
Function DeleteZero(S As String) As String
Dim k As Integer
k = InStr(1, S, Chr(0))
If k <> 0 Then
DeleteZero = Left(S, k - 1)
Else
DeleteZero = S
End If
DeleteZero = Trim(DeleteZero)
End Function
Function AnalyzeMp3(Filename As String, Mp3 As Mp3Info) As Byte
Dim TmpS As String * 4096 'buffer di 4 KB
Dim StartHeader As Long 'inizio relativo del primo frame
Dim ReadPos As Long 'posizione di lettura del buffer
Dim FrameStart As Long 'posizione di inizio del frame corrente
Dim FileStart As Long 'posizione assoluta di inzio del primo frame
Dim TmpB(3) As Byte 'lettura 4 byte header mp3
Dim Mp3Frame(9) As Mp3Header 'i primi 10 frame
Dim j As Integer
If Dir(Filename) = "" Or Trim(Filename) = "" Then Exit Function
FFile = FreeFile
Open Filename For Binary Access Read As #FFile
StartHeader = 0
ReadPos = 1
Mp3.FileLength = LOF(FFile)
Do While StartHeader = 0 And ReadPos + 4096 < Mp3.FileLength
Get #FFile, ReadPos, TmpS
StartHeader = 0
Do While True
StartHeader = InStr(StartHeader + 1, TmpS, Chr(255))
DoEvents
If StartHeader <> 0 Then
FrameStart = ReadPos + StartHeader - 1
For j = 0 To 9
Get #FFile, FrameStart, TmpB
If AnFrame(TmpB, Mp3Frame(j)) = 0 Then Exit For
FrameStart = FrameStart + Mp3Frame(j).ByteLen
Next j
If j = 10 Then Exit Do
Else
Exit Do
End If
Loop
ReadPos = ReadPos + 4096
Loop
FileStart = ReadPos - 4097 + StartHeader
If StartHeader = 0 Then
'errore
Close #FFile
Exit Function
End If
'il file è valido! (o perlomeno si spera lo sia, dopo 10 frame validi!)
'queste informazioni sono uguali per tutti i frame.
Mp3.ChannelMode = Mp3Frame(0).ChannelMode
Mp3.Layer = Mp3Frame(0).Layer
Mp3.MpegVer = Mp3Frame(0).MpegVer
Mp3.CopyRight = Mp3Frame(0).CopyRight
Mp3.Sample = Mp3Frame(0).Sample
Mp3.Original = Mp3Frame(0).Original
Mp3.CBR = False
'ricerca info VBR
If FindXing(FileStart, Mp3) = 0 Then
'se non ci sono controllo che il file sia CBR
For j = 1 To 9
If Mp3Frame(j).BitRate <> Mp3Frame(j - 1).BitRate Then Exit For
Next j
If j <> 10 Then
'nonostante non ci siano le info, il file è VBR e quindi calcolo il bitrate frame per frame
ScanFile FileStart, Mp3
Else
'il file è CBR
Mp3.BitRate = Mp3Frame(0).BitRate
Mp3.Sec = ((Mp3.FileLength - (FileStart - 1)) / 1000) / (Mp3.BitRate / 8)
Mp3.CBR = True
If Mp3.Layer = 1 Then
Mp3.Frames = Mp3.Sec / 384 * Mp3.Sample 'stimato
Else
Mp3.Frames = Mp3.Sec / 1152 * Mp3.Sample 'stimato
End If
End If
End If
'ricerca id3
ReadID3 Mp3
Close #FFile
'la funzione ritorna correttamente
AnalyzeMp3 = 1
End Function
Function AnFrame(Tmp() As Byte, Mp3 As Mp3Header) As Byte
Dim Padding As Byte
If Tmp(0) And 255 <> 255 Then Exit Function
If Tmp(1) And BitSum <> BitSum Then Exit Function
If (Tmp(1) And 8) = 8 Then
Mp3.MpegVer = 1
Else
Mp3.MpegVer = 2
End If
Mp3.Layer = 4 - (Tmp(1) And (2 ^ 2 + 2)) / 2
If Mp3.Layer = 4 Then Exit Function
Mp3.CRC = Tmp(1) And 1
Mp3.BitRate = BitRate(Tmp(2) And BitSum, Mp3.Layer, Mp3.MpegVer)
If Mp3.BitRate = 0 Then Exit Function
Mp3.Sample = Sample(Tmp(2) And (2 ^ 3 + 2 ^ 2), Mp3.MpegVer)
If Mp3.Sample = 0 Then Exit Function
Padding = (Tmp(2) And 2) / 2
Mp3.ChannelMode = (Tmp(3) And (2 ^ 7 + 2 ^ 6)) / 2 ^ 6
Mp3.CopyRight = (Tmp(3) And 2 ^ 3) / 2 ^ 3
Mp3.Original = (Tmp(3) And 2 ^ 2) / 2 ^ 2
If Mp3.Layer = 1 Then
Mp3.ByteLen = ((12 * CLng(Mp3.BitRate) * 1000) \ Mp3.Sample + Padding) * 4 '+ Mp3.CRC * 2
Else
Mp3.ByteLen = (144 * CLng(Mp3.BitRate) * 1000) \ Mp3.Sample + Padding '+ Mp3.CRC * 2
End If
AnFrame = 1
End Function
Function BitRate(Num As Byte, Layer As Byte, Mpeg As Byte) As Integer
Dim CF As Variant
If Mpeg = 1 And Layer = 1 Then
CF = Array(0, 32, 64, 96, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, 448, 0)
ElseIf Mpeg = 1 And Layer = 2 Then
CF = Array(0, 32, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 384, 0)
ElseIf Mpeg = 1 And Layer = 3 Then
CF = Array(0, 32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 0)
ElseIf Mpeg = 2 And Layer = 1 Then
CF = Array(0, 32, 48, 56, 64, 80, 96, 112, 128, 144, 160, 176, 192, 224, 256, 0)
ElseIf Mpeg = 2 And (Layer = 2 Or Layer = 3) Then
CF = Array(0, 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160, 0)
End If
BitRate = CF(Num / 16)
End Function
Function Sample(Num As Byte, Mpeg As Byte) As Long
Dim CF As Variant
CF = Array(44100, 48000, 32000, 0)
Sample = (CF(Num / 4)) / Mpeg
End Function
Function ChannelMode(Num As Byte) As String
Dim CF As Variant
CF = Array("Stereo", "Joint Stereo", "Dual channel", "Mono")
ChannelMode = CF(Num)
End Function
Function FindXing(ByVal Start As Long, Mp3 As Mp3Info) As Byte
Dim TmpS As String * 4
Dim Flags As Byte
Dim Frames As Integer
Dim Filelenght As Long
Dim Tmp(3) As Byte
If Mp3.MpegVer = 1 Then
Start = Start + 36
Else
Start = Start + 21
End If
Get #FFile, Start, TmpS
If TmpS <> "Xing" Then Exit Function
Get #FFile, Start + 7, Flags
If Flags And 1 = 0 Or Flags And 2 = 0 Then Exit Function
Get #FFile, Start + 8, Tmp
Mp3.Frames = ComposeLong(Tmp)
Get #FFile, Start + 12, Tmp
Filelenght = ComposeLong(Tmp)
If Mp3.Layer = 1 Then
Mp3.Sec = Mp3.Frames * 384 / Mp3.Sample
Else
Mp3.Sec = Mp3.Frames * 1152 / Mp3.Sample
End If
Mp3.BitRate = (Filelenght * 8 / 1000) / Mp3.Sec
FindXing = 1
End Function
Function ComposeLong(Tmp() As Byte) As Long
ComposeLong = CLng(Tmp(3)) + CLng(Tmp(2)) * 255 + CLng(Tmp(1)) * 65535 + CLng(Tmp(0)) * 16777215
End Function
Sub ScanFile(ByVal Start As Long, Mp3 As Mp3Info)
Dim Mp3Head As Mp3Header
Dim Pos As Long
Dim Tmp(3) As Byte
Dim TempBitrate As Long
Do While Start + 4 < Mp3.FileLength
Get #FFile, Start, Tmp
If AnFrame(Tmp, Mp3Head) = 0 Then Exit Do
Start = Start + Mp3Head.ByteLen
Mp3.Frames = Mp3.Frames + 1
TempBitrate = TempBitrate + Mp3Head.BitRate
Loop
If Mp3.Layer = 1 Then
Mp3.Sec = Mp3.Frames * 384 / Mp3.Sample
Else
Mp3.Sec = Mp3.Frames * 1152 / Mp3.Sample
End If
Mp3.BitRate = TempBitrate / Mp3.Frames
End Sub
Inserisci in un form una textbox dove inserisci il percorso e il nome del file mp3 da analizzare chiamata "txtfile" e una textbox denominata "txtinfo" con proprietà multiline = true e un commandbutton chiamato "cmdAnalyze":