Zurück zur Homepage

MP3-Liste

Auf ihrer Platte haben sich viele MP3's angesammelt?
Meine Klasse MP3_Infos liefert die Informationen einer MP3-Datei wie Titel, Artist, Songlänge, Genre, Album, Jahr, Track, Kommentar, Bitrate, Layer, Version, Samplingrate, Aufzeichnungsmodus, Rauschunterdrückung, Original- und Copyrightflag. Wo es Sinn macht, können die Daten auch zurückgeschrieben werden. Die neuen (seltenen) ID3 V2 Framebasierenden Tags werden auch gelesen, können in der vorliegenden Version aber nicht zurückgeschrieben werden.
Im vorliegenden Modul kann über einen Dialog (API) ein Anfangsverzeichnis ausgewählt werden, an dem die Suche nach MP3's beginnt. Da Dir$ Rekursionen nicht packt, werden die untergeordneten Verzeichnisse in einem Array zwischengespeichert und später abgearbeitet. Die Infos der Dateien werden in einer Collection gespeichert, diese wird dann als Element einer Übergeordneten Collection übergeben. Nachher werden die Infos in das Tabellenblatt geschrieben, gleichzeitig wird je ein Hyperlink erzeugt, damit man durch einen simlen Klick das Lied abspielen kann.

 Beispieldatei (mpx.zip 55 KB)

'Beginn Klasse

Private iPfad As String
Private iSamplingrate As String
Private iBitrate As Double
Private iAufzeichnungsmodus As String
Private iMpegArt As Byte
Private iMpegLayer As Byte
Private iLänge As Long
Private iCopyright As Boolean
Private iOriginal As Boolean
Private iEmphases As String
Private iTrack As String
Private iGenre()
Private TagInfo As MP3Tag
Private iv3Album As String
Private iv3Titel As String
Private iv3Artist As String
Private iv3Track As String
Private iv3Genre As String
Private iv3Kommentar As String
Private iv3Jahr As String
Private iv3Sprache As String
Private iv3Länge As String
Private iv3Typ As String
Private iv3UrspKünstler As String
Private iv3PlayZähler As String
Private iv3Encodet As String
Private iv3Link As String
Private iv3Copyr As String
Private iv3Composer As String
Private iv3Publisher As String
Private iv3Software As String
Private Header As String * 10000
Private iv3Sonstiges As String

Private Type MP3Tag
    Tag As String * 3
    Titel As String * 30
    Artist As String * 30
    Album As String * 30
    Jahr As String * 4
    Kommentar As String * 29
    Track As Byte
    Genre As Byte

End Type

 

Private Sub InfosHolen()
Dim iHeader() As Byte
Dim DateiNr As Long
Dim Header As String
Dim Headerbeginn As Long
Dim zähler As Long
Dim ID3V3pos As Long, IDV3Länge(0 To 3) As Byte
Dim ID3Vers(0 To 1) As Byte, IDV3TagLänge As Long
DateiNr = FreeFile
Open iPfad For Binary As #DateiNr
    iLänge = LOF(DateiNr)
    'Einfach ein paar tausend Zeichen einlesen, irgendwo
    'darin ist  schon ein Frame

    Get #DateiNr, 1, Header
    Do
        'Das Syncword des ersten Frames suchen. 12 Bits &HFFF
        'Noch nie beobachtet, aber auch &HFFE möglich.

        zähler = zähler + 1
        zähler = InStr(zähler, Header, Chr(&HFF))
        If ((Asc(Mid$(Header, zähler + 1, 1)) And &HF0) = &HF0) _
            Or ((Asc(Mid$(Header, zähler + 1, 1)) And &HE0) = &HE0) Then
            'Syncword gefunden
            Headerbeginn = zähler
            'Headergröße gesamt ist nur 4 Byte, bleiben nach Abzug
            'des Syncwords 12 Bits übrig

            iHeader = StrConv(Mid$(Header, _
                Headerbeginn, 4), vbFromUnicode)
            'Den Tag auslesen, der die infos über Musikstück enthält.
            'Das sind die letzten 128 Bytes

            Get #DateiNr, iLänge - 127, TagInfo
            If LCase(TagInfo.Tag) <> "tag" Then
                TaginfoLöschen
                Get #DateiNr, 1, Header
                ID3V3pos = InStr(Header, "ID3")
                If ID3V3pos <> 0 Then
                    Get #DateiNr, ID3V3pos + 3, ID3Vers
                    ' ID3V2 Tag wurde gefunden
                    Get #DateiNr, ID3V3pos + 6, IDV3Länge
                    'Da &HFFF nicht vorkommen darf, sind jeweils
                    'die 4 oberen Bits eines Bytes Lo. Deshalb die
                    'umständliche Berechnung

                    IDV3TagLänge = CLng(IDV3Länge(0)) * 16384 _
                    + CLng(IDV3Länge(1)) * 2048 _
                    + CLng(IDV3Länge(2)) * 256 _
                    + CLng(IDV3Länge(3)) + 10
                    Get #DateiNr, 1, Header
                    ID3Info Header, ID3Vers(0)
                End If
            Else
                iAufzeichnungsmodus = Aufzeichnungsmodus(iHeader)
                iSamplingrate = Samplingrate(iHeader)
                iBitrate = Bitratenwert(iHeader)
                iEmphases = Emphases(iHeader)
                iCopyright = (iHeader(3) And 2 ^ 3) <> 0
                iOriginal = (iHeader(3) And 2 ^ 2) <> 0
            End If
            Exit Do
        End If
    Loop While zähler <> 0
Fehlerbehandlung:
Close
End Sub

Private Function Emphases(a As Variant) As String
If a(0) = 0 Then Exit Function
'Emphase Algorithmus zur Qualitätsverbesserung
Select Case (a(3) And 3)
    Case 0
        Emphases = "Keine"
    Case 1
        Emphases = "50/15 ms "
    Case 2
        Emphases = "reserviert"
    Case 3
        Emphases = "CCITT j.17"
End Select
End Function

Private Function Aufzeichnungsmodus(a As Variant) As String
If a(0) = 0 Then Exit Function
Select Case (a(3) \ 2 ^ 6)
    Case 0
        Aufzeichnungsmodus = "Stereo"
    Case 1
        Aufzeichnungsmodus = "JointStereo"
    Case 2
        Aufzeichnungsmodus = "DualChannel"
    Case 3
        Aufzeichnungsmodus = "Mono"
End Select
End Function

Private Function Samplingrate(a As Variant) As String
If a(0) = 0 Then Exit Function
Select Case (a(2) \ 2 ^ 2) And 3
    Case 0
        Samplingrate = "44100Hz - 22050Hz"
    Case 1
        Samplingrate = "48000Hz - 24000Hz"
    Case 2
        Samplingrate = "32000Hz - 16000Hz"
End Select
End Function

Private Function Bitratenwert(a As Variant) As Double
'Die Kombination MPEG1 oder MPEG2 und der Index
'ergibt die Position in der festgelegten Tabelle

Dim Rate As Byte
Dim dummy(1 To 6)
Dim i As Long, k As Long, l As Long
Dim Bitraten(1 To 2, 1 To 3, 1 To 14)
On Error Resume Next
If a(0) = 0 Then Exit Function
If a(1) = 0 Then Exit Function
If a(2) = 0 Then Exit Function
If a(1) And 2 ^ 3 Then iMpegArt = 1
iMpegArt = 2 - iMpegArt
iMpegLayer = 4 - (a(1) \ 2) And 3
If iMpegLayer = 0 Then iMpegLayer = 3
Rate = (a(2) \ 2 ^ 4)
dummy(1) = Array(32, 64, 96, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, 448)
dummy(2) = Array(32, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 384)
dummy(3) = Array(32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320)
dummy(4) = dummy(1)
dummy(5) = dummy(2)
dummy(6) = Array(8, 16, 24, 32, 64, 80, 65, 64, 128, 160, 112, 128, 256, 320)
For i = 0 To 1
    For k = 1 To 3
        For l = 0 To 13
            Bitraten(i + 1, k, l + 1) = dummy(i * 3 + k)(l)
        Next
    Next
Next
Bitratenwert = Bitraten(iMpegArt, iMpegLayer, Rate)
End Function

Private Function GenreString(Wert As Byte) As String
On Error Resume Next
GenreString = iGenre(Wert)
End Function

Private Function NullTrim(a As String) As String
Dim zähler As Long, b As String
For zähler = 1 To Len(a)
    b = Mid$(a, zähler, 1)
    If (Asc(b) > 31) And (Asc(b) < 128) Then
        NullTrim = NullTrim & b
    End If
Next
NullTrim = Trim(NullTrim)
End Function

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Nur Leserechte. Änderungen machen keinen Sinn

Public Property Get Layer() As String
Select Case iMpegLayer
    Case 0
        Layer = "Ungültig"
    Case 1
        Layer = "Layer 1 Dig. Compact Casette"
    Case 2
        Layer = "Layer 2 DAB, MUSICAM"
    Case 3
        Layer = "Layer 3 MP3"
End Select
End Property

Public Property Get Songlänge() As String
    On Error Resume Next
    Songlänge = Format$((iLänge * 8 / (iBitrate * 1000)) / (3600 * CDbl(24)), "hh:mm:ss")
End Property

Public Property Get Sampling() As String
    Sampling = iSamplingrate
End Property

Public Property Get Bitrate() As String
    Bitrate = iBitrate
End Property

Public Property Get Stereomodus() As String
    Stereomodus = iAufzeichnungsmodus
End Property

Public Property Get MpegArt() As String
    MpegArt = "Mpeg-" & iMpegArt
End Property

Public Property Get MpegLayer() As String
    MpegLayer = iMpegLayer
End Property

Public Property Get Copyright() As Boolean
    Copyright =iCopyright
End Property

Public Property Get Original() As Boolean
    Original = iOriginal
End Property

Public Property Get Rauschunterdrückung() As String
    Rauschunterdrückung = iEmphases
End Property

Public Property Get Pfad() As String
    Pfad = iPfad
End Property

Public Property Let Pfad(ByVal vNewValue As String)
    iPfad = vNewValue
    ZusatzinfosLöschen
    InfosHolen
End Property

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Lesen und Schreiben

Public Sub WerteZurückschreiben()
Dim DateiNr As Long
DateiNr = FreeFile
On Error GoTo Fehlerbehandlung
Open iPfad For Binary As #DateiNr
Put #DateiNr, LOF(DateiNr) - 127, TagInfo
Close
Fehlerbehandlung:
End Sub

Public Property Get Titel() As String
    Titel = NullTrim(TagInfo.Titel)
End Property

Public Property Let Titel(ByVal vNewValue As String)
    TagInfo.Titel = vNewValue
End Property

Public Property Get Artist() As String
    Artist = NullTrim(TagInfo.Artist)
End Property

Public Property Let Artist(ByVal vNewValue As String)
    TagInfo.Artist = vNewValue
End Property

Public Property Get Album() As String
    Album = NullTrim(TagInfo.Album)
End Property

Public Property Let Album(ByVal vNewValue As String)
    TagInfo.Album = vNewValue
End Property

Public Property Get Jahr() As String
    Jahr = NullTrim(TagInfo.Jahr)
End Property

Public Property Let Jahr(ByVal vNewValue As String)
    TagInfo.Jahr = vNewValue
End Property

Public Property Get Kommentar() As String
    Kommentar = NullTrim(TagInfo.Kommentar)
End Property

Public Property Let Kommentar(ByVal vNewValue As String)
    TagInfo.Kommentar = vNewValue
End Property

Public Property Get Genre() As String
    Genre = GenreString(TagInfo.Genre)
End Property

Public Property Get GenreEnum()
    GenreEnum = iGenre
End Property

Public Property Let GenreNummer(ByVal vNewValue As Byte)
    TagInfo.Genre = vNewValue
End Property

Public Property Get Track() As String
        Track = TagInfo.Track
End Property

Public Property Let Track(ByVal vNewValue As String)
    TagInfo.Track = vNewValue
End Property

Public Property Get ID3Genre() As String
    ID3Genre = iv3Genre
End Property

Public Property Get ID3Album() As String
    ID3Album = iv3Album
End Property

Public Property Get ID3Titel() As String
    ID3Titel = iv3Titel
End Property

Public Property Get ID3Artist() As String
    ID3Artist = iv3Artist
End Property

Public Property Get ID3Track() As String
    ID3Track = iv3Track
End Property

Public Property Get ID3Kommentar() As String
    ID3Kommentar = iv3Kommentar
End Property

Public Property Get ID3Jahr() As String
    ID3Jahr = iv3Jahr
End Property

Public Property Get ID3Sprache() As String
    ID3Sprache = iv3Sprache
End Property

Public Property Get ID3Länge() As String
    ID3Länge = iv3Länge
End Property

Public Property Get ID3Typ() As String
    ID3Typ = iv3Typ
End Property

Public Property Get ID3UrspKünstler() As String
    ID3UrspKünstler = iv3UrspKünstler
End Property

Public Property Get ID3PlayZähler() As String
    ID3PlayZähler = iv3PlayZähler
End Property

Public Property Get ID3Encodet() As String
    ID3Encodet = iv3Encodet
End Property

Public Property Get ID3Link() As String
    ID3Link = iv3Link
End Property

Public Property Get ID3Copyr() As String
    ID3Copyr = iv3Copyr
End Property

Public Property Get ID3Composer() As String
    ID3Composer = iv3Composer
End Property

Public Property Get ID3Publisher() As String
    ID3Publisher = iv3Publisher
End Property

Public Property Get ID3Software() As String
    ID3Software = iv3Software
End Property

Public Property Get ID3Sonstiges() As String
    ID3Sonstiges = iv3Sonstiges
End Property

Private Sub ID3Info(Infobuffer As String, Version As Byte)
Dim Fname As String
Dim FLänge As String
Dim Flag As String
Dim FInhalt As String
Dim dummy As String
Dim IDV3TagLänge As Long
Dim IDV3Länge() As Byte
If Mid$(Infobuffer, 6, 1) = Chr(4) Then
    Infobuffer = Mid$(Infobuffer, 10)
End If
ZusatzinfosLöschen
Infobuffer = Mid$(Infobuffer, 11)
Do
    If Version = 3 Or Version = 4 Then
        Fname = Left$(Infobuffer, 4)
        If InStr(1, Fname, "3DI") Then Exit Do
        FLänge = Mid$(Infobuffer, 5, 4)
        'Da &HFFF nicht vorkommen darf, sind jeweils
        'die 4 oberen Bits eines Bytes Lo. Deshalb die
        'umständliche Berechnung

        IDV3Länge = StrConv(FLänge, vbFromUnicode)
        IDV3TagLänge = CLng(IDV3Länge(0)) * 16384 _
            + CLng(IDV3Länge(1)) * 2048 _
            + CLng(IDV3Länge(2)) * 256 _
            + CLng(IDV3Länge(3)) + 10
        Flag = Mid$(Infobuffer, 9, 2)
        If IDV3TagLänge > 11 Then
            dummy = IDV3TagLänge - 11
            FInhalt = Mid$(Infobuffer, 12, dummy)
            Select Case Fname
                Case "TALB": iv3Album = FInhalt
                Case "TIT2": iv3Titel = FInhalt
                Case "TPE1": iv3Artist = FInhalt
                Case "TRCK": iv3Track = FInhalt
                Case "TCON": iv3Genre = FInhalt
                Case "COMM": iv3Kommentar = FInhalt
                Case "TYER": iv3Jahr = FInhalt
                Case "TLAN": iv3Sprache = FInhalt
                Case "TLEN": iv3Länge = FInhalt
                Case "TMED": iv3Typ = FInhalt
                Case "TOPE": iv3UrspKünstler = FInhalt
                Case "PCNT": iv3PlayZähler = FInhalt
                Case "TENC": iv3Encodet = FInhalt
                Case "WXXX": iv3Link = FInhalt
                Case "TCOP": iv3Copyr = FInhalt
                Case "TCOM": iv3Composer = FInhalt
                Case "TPUB": iv3Publisher = FInhalt
                Case "TSSE": iv3Software = FInhalt
                Case Else: iv3Sonstiges = FInhalt
            End Select
        End If
        Infobuffer = Mid$(Infobuffer, IDV3TagLänge + 1)
    ElseIf Version = 2 Then
        Fname = Left$(Infobuffer, 4)
        If InStr(1, Fname, "3DI") Then Exit Do
        FLänge = Mid$(Infobuffer, 5, 4)
        'Da &HFFF nicht vorkommen darf, sind jeweils
        'die 4 oberen Bits eines Bytes Lo. Deshalb die
        'umstänldiche Berechnung

        IDV3Länge = StrConv(FLänge, vbFromUnicode)
        IDV3TagLänge = CLng(IDV3Länge(0)) * 16384 _
            + CLng(IDV3Länge(1)) * 2048 _
            + CLng(IDV3Länge(2)) * 256 _
            + CLng(IDV3Länge(3)) + 10
        If IDV3TagLänge > 7 Then
            dummy = IDV3TagLänge - 7
            FInhalt = Mid$(Infobuffer, 8, dummy)
            Select Case Fname
              Case "TAL": iv3Album = FInhalt
              Case "TT2": iv3Titel = FInhalt
              Case "TP1": iv3Artist = FInhalt
              Case "TRK": iv3Track = FInhalt
              Case "TCO": iv3Genre = FInhalt
              Case "COM": iv3Kommentar = FInhalt
              Case "TYE": iv3Jahr = FInhalt
              Case "TLA": iv3Sprache = FInhalt
              Case "TMT": iv3Typ = FInhalt
              Case "TOA": iv3UrspKünstler = FInhalt
              Case "TEN": iv3Encodet = FInhalt
              Case "TCR": iv3Copyr = FInhalt
              Case "TCM": iv3Composer = FInhalt
              Case "TSS": iv3Software = FInhalt
              Case Else: iv3Sonstiges = FInhalt
            End Select
        End If
        Infobuffer = Mid$(Infobuffer, IDV3TagLänge + 1)
    End If
Loop Until Len(Infobuffer) = 0
End Sub

Private Sub VariablenZurücksetzen()
    iSamplingrate = ""
    iBitrate = 0
    iAufzeichnungsmodus = ""
    iMpegArt = 0
    iMpegLayer = 0
    iLänge = 0
    iCopyright = False
    iOriginal = False
    iEmphases = ""
End Sub

Private Sub TaginfoLöschen()
With TagInfo
    .Album = ""
    .Artist = ""
    .Genre = 12
    .Jahr = ""
    .Kommentar = ""
    .Titel = ""
    .Track = 0
End With
End Sub

Private Sub ZusatzinfosLöschen()
    iv3Album = ""
    iv3Titel = ""
    iv3Artist = ""
    iv3Track = ""
    iv3Genre = ""
    iv3Kommentar = ""
    iv3Jahr = ""
    iv3Sprache = ""
    iv3Länge = ""
    iv3Typ = ""
    iv3UrspKünstler = ""
    iv3PlayZähler = ""
    iv3Encodet = ""
    iv3Link = ""
    iv3Copyr = ""
    iv3Composer = ""
    iv3Publisher = ""
    iv3Software = ""
End Sub

Private Sub Class_Initialize()
ReDim iGenre(0 To 125)
iGenre(0) = "Blues"
iGenre(1) = "Classic Rock"
iGenre(2) = "Country"
iGenre(3) = "Dance"
iGenre(4) = "Disco"
iGenre(5) = "Funk"
iGenre(6) = "Grunge"
iGenre(7) = "Hip-Hop"
iGenre(8) = "Jazz"
iGenre(9) = "Metal"
iGenre(10) = "New Age"
iGenre(11) = "Oldies"
iGenre(12) = "Other"
iGenre(13) = "Pop"
iGenre(14) = "R&B"
iGenre(15) = "Rap"
iGenre(16) = "Reggae"
iGenre(17) = "Rock"
iGenre(18) = "Techno"
iGenre(19) = "Industrial"
iGenre(20) = "Alternative"
iGenre(21) = "Ska"
iGenre(22) = "Death Metal"
iGenre(23) = "Pranks"
iGenre(24) = "Soundtrack"
iGenre(25) = "Euro-Techno"
iGenre(26) = "Ambient"
iGenre(27) = "Trip-Hop"
iGenre(28) = "Vocal"
iGenre(29) = "Jazz Funk"
iGenre(30) = "Fusion"
iGenre(31) = "Trance"
iGenre(32) = "Classical"
iGenre(33) = "Instrumental"
iGenre(34) = "Acid"
iGenre(35) = "House"
iGenre(36) = "Game"
iGenre(37) = "Sound Clip"
iGenre(38) = "Gospel"
iGenre(39) = "Noise"
iGenre(40) = "AlternRock"
iGenre(41) = "Bass"
iGenre(42) = "Soul"
iGenre(43) = "Punk"
iGenre(44) = "Space"
iGenre(45) = "Meditative"
iGenre(46) = "Instrumental Pop"
iGenre(47) = "Instrumental Rock"
iGenre(48) = "Ethnic"
iGenre(49) = "Gothic"
iGenre(50) = "Darkwave"
iGenre(51) = "Techno -Industrial"
iGenre(52) = "Electronic"
iGenre(53) = "Pop-Folk"
iGenre(54) = "Eurodance"
iGenre(55) = "Dream"
iGenre(56) = "Southern Rock"
iGenre(57) = "Comedy"
iGenre(58) = "Cult"
iGenre(59) = "Gangsta"
iGenre(60) = "Top 40"
iGenre(61) = "Christian Rap"
iGenre(62) = "Pop/Funk"
iGenre(63) = "Jungle"
iGenre(64) = "Native American"
iGenre(65) = "Cabaret"
iGenre(66) = "New Wave"
iGenre(67) = "Psychadelic"
iGenre(68) = "Rave"
iGenre(69) = "Showtunes"
iGenre(70) = "TriGenreiler"
iGenre(71) = "Lo-Fi"
iGenre(72) = "Tribal"
iGenre(73) = "Acid Punk"
iGenre(74) = "Acid Jazz"
iGenre(75) = "Polka"
iGenre(76) = "Retro"
iGenre(77) = "MusiciGenrel"
iGenre(78) = "Rock & Roll"
iGenre(79) = "Hard Rock"
iGenre(80) = "Folk"
iGenre(81) = "Folk-Rock"
iGenre(82) = "National Folk"
iGenre(83) = "Swing"
iGenre(84) = "Fast Fusion"
iGenre(85) = "Bebob"
iGenre(86) = "Latin"
iGenre(87) = "Revival"
iGenre(88) = "Celtic"
iGenre(89) = "Bluegrass"
iGenre(90) = "Avantgarde"
iGenre(91) = "Gothic Rock"
iGenre(92) = "Progressive Rock"
iGenre(93) = "Psychedelic Rock"
iGenre(94) = "Symphonic Rock"
iGenre(95) = "Slow Rock"
iGenre(96) = "Big Band"
iGenre(97) = "Chorus"
iGenre(98) = "Easy Listening"
iGenre(99) = "Acoustic"
iGenre(100) = "Humour"
iGenre(101) = "Speech"
iGenre(102) = "Chanson"
iGenre(103) = "Opera"
iGenre(104) = "Chamber Music"
iGenre(105) = "Sonata"
iGenre(106) = "Symphony"
iGenre(107) = "Booty Bass"
iGenre(108) = "Primus"
iGenre(109) = "Porn Groove"
iGenre(110) = "Satire"
iGenre(111) = "Slow Jam"
iGenre(112) = "Club"
iGenre(113) = "Tango"
iGenre(114) = "Samba"
iGenre(115) = "Folklore"
iGenre(116) = "Ballad"
iGenre(117) = "Power Ballad"
iGenre(118) = "Rhythmic Soul"
iGenre(119) = "Freestyle"
iGenre(120) = "Duet"
iGenre(121) = "Punk Rock"
iGenre(122) = "Drum Solo"
iGenre(123) = "Acapella"
iGenre(124) = "Euro-House"
iGenre(125) = "Dance Hall"
End Sub

 

'Beginn Modul

Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
  "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
  As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
  "SHGetPathFromIDListA" (ByVal pidl As Long, _
  ByVal pszPath As String) As Long

 Private 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

Private MP3Klasse As New MP3_Infos
Private Const BIF_RETURNONLYFSDIRS = &H1
Private DateiZähler As Long 

Sub start()
Dim Liste As New Collection
Dim a, zähler As Long, zähler1 As Long
Dim startdir As String
  On Error Resume Next
  'Startverzeichnis wählen
  startdir = VerzeichnisWählen()
  If startdir = "" Then Exit Sub
  DateiZähler = 0
  'Collection mit vorhandenen Liedern füllen
  MP3_Liste startdir, Liste, "mp3"
  zähler = 1
  With Sheets("MP3")
    'Informationen ins Blatt eintragen
    .Cells.ClearContents
    Application.ScreenUpdating = False
    For Each a In Liste
      zähler = zähler + 1
      For zähler1 = 1 To a.Count
        If zähler1 = 2 Then
          'In die zweite Spalte kommt ein Link
          If zähler > 2 Then
            'Hyperlink auf die Datei erzeugen
            .Hyperlinks.Add Anchor:=.Cells(zähler, zähler1), _
              Address:=a.Item(zähler1)
          Else
             'aber nur, wenns nicht die Überschrift ist
              .Cells(zähler, zähler1) = a.Item(zähler1)
          End If
        Else
          'Info eintragen
          Cells(zähler, zähler1) = a.Item(zähler1)
        End If
      Next
    Next
  End With
 Application.StatusBar = False
 Application.ScreenUpdating = True
End Sub

Private Sub MP3_Liste(startdir As String, ByRef Liste As Collection, Filter As String)
Dim V() As String, zähler As Long, Dateiname As String
Dim DateiNr As Long, aktVerz As String
Dim Header As String, Bitrate As Double
Dim Sampling As String, Modus As String
Dim Frames As Long, Framelänge As Long
Dim MpegLayer As Long, SamplesProFrame As Long
Dim Nutzlänge As Double
Dim BitHeader(1 To 4) As Byte
Dim Länge As Double, Headerbeginn As Long
Dim Informationen As Collection
Dim dummy
  If Left$(Filter, 1) <> "." Then Filter = "." & Filter
  If Liste.Count = 0 Then
    'Erster Eintrag in der Collection Liste
    'ist eine Collection mit den Überschriften
    Set Informationen = New Collection
    Informationen.Add "Datei", "Datei"
    Informationen.Add "Pfad", "Pfad"
    Informationen.Add "Titel", "Titel"
    Informationen.Add "Artist", "Artist"
    Informationen.Add "Songlänge", "Songlänge"
    Informationen.Add "Genre", "Genre"
    Informationen.Add "Album", "Album"
    Informationen.Add "Jahr", "Jahr"
    Informationen.Add "Track", "Track"
    Informationen.Add "Kommentar", "Kommentar"
    Informationen.Add "Bitrate", "Bitrate"
    Informationen.Add "MpegLayer", "MpegLayer"
    Informationen.Add "MpegArt", "MpegArt"
    Informationen.Add "Sampling", "Sampling"
    Informationen.Add "Stereomodus", "Stereomodus"
    Informationen.Add "Rauschunterdrückung", "Rauschunterdrückung"
    Informationen.Add "Original", "Original"
    Informationen.Add "Copyright", "Copyright"
    Informationen.Add "ID3Sprache", "ID3Sprache"
    Informationen.Add "ID3UrspKünstler", "ID3UrspKünstler"
    Informationen.Add "ID3Composer", "ID3Composer"
    Informationen.Add "ID3Publisher", "ID3Publisher"
    Informationen.Add "ID3Software", "ID3Software"
    Informationen.Add "ID3PlayZähler", "ID3PlayZähler"
    Informationen.Add "ID3Link", "ID3Link"
    Informationen.Add "ID3Typ", "ID3Typ"
    Informationen.Add "ID3Sonstiges", "ID3Sonstiges"
    Liste.Add Informationen, "Überschrift"
  End If
  ReDim V(1 To 100)
  If Right$(startdir, 1) <> "\" Then
    'Nachschauen, ob übergebener Pfad auch einen Backslash enthält.
    'Wenn nicht, dann anhängen
    startdir = startdir & "\"
  End If
  aktVerz = startdir
  startdir = startdir & "*"
  Dateiname = Dir$(startdir, vbDirectory Or vbNormal)
  Do While Dateiname <> ""
    If GetAttr(aktVerz & Dateiname) And vbDirectory Then
    'wenn Datei ein Verzeichnis ist
      If Right$(Dateiname, 1) <> "." Then
        'und zwar ein untergeordnetes,
        zähler = zähler + 1
        'dann ein Array mit Verzeichnissen füllen.
        If zähler > UBound(V) Then
          ReDim Preserve V(1 To zähler + 1)
        End If
        V(zähler) = Dateiname
      End If
    Else
      'Handelt es sich um eine Datei,
      If LCase(Right$(Dateiname, Len(Filter))) = LCase(Filter) Then
        'und entspricht sie noch den Filterbedingungen,
        With MP3Klasse
            'dann den Pfad an die Klasse übergeben
            .Pfad = aktVerz & Dateiname
            'und Infos von Klasse in neue Collection schreiben.
            Set Informationen = New Collection
            Informationen.Add Dateiname, "Datei"
            Informationen.Add .Pfad, "Pfad"
            Informationen.Add .Titel, "Titel"
            Informationen.Add .Artist, "Artist"
            Informationen.Add .Songlänge, "Songlänge"
            Informationen.Add .Genre, "Genre"
            Informationen.Add .Album, "Album"
            Informationen.Add .Jahr, "Jahr"
            Informationen.Add .Track, "Track"
            Informationen.Add .Kommentar, "Kommentar"
            Informationen.Add .Bitrate, "Bitrate"
            Informationen.Add .MpegLayer, "MpegLayer"
            Informationen.Add .MpegArt, "MpegArt"
            Informationen.Add .Sampling, "Sampling"
            Informationen.Add .Stereomodus, "Stereomodus"
            Informationen.Add .Rauschunterdrückung, "Rauschunterdrückung"
            Informationen.Add .Original, "Original"
            Informationen.Add .Copyright, "Copyright"
            Informationen.Add .ID3Sprache, "ID3Sprache"
            Informationen.Add .ID3UrspKünstler, "ID3UrspKünstler"
            Informationen.Add .ID3Composer, "ID3Composer"
            Informationen.Add .ID3Publisher, "ID3Publisher"
            Informationen.Add .ID3Software, "ID3Software"
            Informationen.Add .ID3PlayZähler, "ID3PlayZähler"
            Informationen.Add .ID3Link, "ID3Link"
            Informationen.Add .ID3Typ, "ID3Typ"
            Informationen.Add .ID3Sonstiges, "ID3Sonstiges"
            DateiZähler = DateiZähler + 1
            Application.StatusBar = "Dateiinfos (" & DateiZähler - 1 & ") =   " & aktVerz & Dateiname
            If DateiZähler Mod 20 = 0 Then DoEvents
            'und als Element an die Collection Liste hängen.
            Liste.Add Informationen, aktVerz & Dateiname
          End With
      End If
  End If
  Dateiname = Dir$()
  Loop
  'Jetzt erst werden die Unterverzeichnisse abgearbeitet,
  'weil Dir$ mit Rekursionen nicht klarkommt.
  If zähler = 0 Then Exit Sub
  ReDim Preserve V(1 To zähler)
  For zähler = 1 To UBound(V)
    'Jetzt ruft sich diese Funktion noch mal auf.
    MP3_Liste aktVerz & V(zähler), Liste, Filter
  Next

End Sub

 

Public Function VerzeichnisWählen() As String
Dim Ret As Long
Dim Browse As BROWSEINFO
Dim Liste As Long
Dim Pfad As String, wPos As Integer
  Browse.lpszTitle = "Bitte ein Startverzeichnis wählen"
  Browse.ulFlags = BIF_RETURNONLYFSDIRS
  Liste = SHBrowseForFolder(Browse)
  Pfad = String(1024, 0)
  Ret = SHGetPathFromIDList(ByVal Liste, ByVal Pfad)
  If Ret Then
  VerzeichnisWählen = NullTrim(Pfad)
  End If
End Function

Private Function NullTrim(a As String) As String
Dim zähler As Long, b As String
  For zähler = 1 To Len(a)
    b = Mid$(a, zähler, 1)
    If (Asc(b) > 31) And (Asc(b) < 128) Then
      NullTrim = NullTrim & b
    End If
  Next
  NullTrim = Trim(NullTrim)
End Function