[VB6] Write MP3 Album Art and other tags using the Windows Property System

[fafalone]

None of the VB ID3 classes seem to support adding a thumbnail for the album art in an MP3 (the APIC tag), and I've tried to add such support without much success*. But earlier today, we were talking about writing Unicode to ID3 tags, which my shell browser control does through the Windows Property System, and I got thinking about album covers. When I saw Microsoft listed PKEY_ThumbnailStream on a page called 'Metadata Properties For Media Files' I got curious if that meant MP3 to.
It did, and my browser could then display them as thumbnails thanks to a technique based on dilettante's project to read that property. And that of course led to wondering... my shell browser reads it through an object's IPropertyStore, writes other properties through that... could I write album art? It's a little tricky but the answer is yes.

So here's a demo of that technique. It also has an option to write the Album Title to demonstrate writing the more simple tags through Windows as well. Note that the VB textbox doesn't support Unicode, but if you did pass a Unicode string to the function, it works.

Requirements
-Windows Vista or newer
-oleexp.tlb 4.6 or higher


The Code
Here's what the core routine looks like (declares/support funcs not included, see download)

Private Function WriteCover(sJPG As String, sMP3 As String, Optional sTitle As String = "") As Long
Dim hFile As Long, nFile As Long, lp As Long
Dim hBitmap As Long
Dim hImage As Long
Dim hGG As Long, lpGlobal As Long
hFile = CreateFileW(StrPtr(sJPG), FILE_READ_DATA, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile Then
    'read bitmap file into memory
    nFile = GetFileSize(hFile, lp)
    hGG = GlobalAlloc(GPTR, nFile)
    lpGlobal = GlobalLock(hGG)
    If lpGlobal Then
        Dim oStrm As oleexp.IUnknown
        Call ReadFile(hFile, ByVal lpGlobal, nFile, nFile, ByVal 0&)
        Call GlobalUnlock(hGG)
        Call CreateStreamOnHGlobal(hGG, 1, oStrm)
    
        Dim vbr As Variant, vpr As Variant
    
        Set vbr = oStrm
        VariantToPropVariant vbr, vpr
        
        'At this point since VARIANT doesn't support VT_STREAM, its type is VT_UNKNOWN
        'So the PROPVARIANT is also VT_UNKNOWN. But that will give us a type mismatch.
        'PropVariantChangeType seems to only support numbers, so we manually change the type
        'to VT_STREAM, which is valid because our IUnknown object is an IStream.
        'In the PROPVARIANT structure, the first two bytes are the VARENUM value indicating type
        Dim vt As Integer
        vt = VT_STREAM
        CopyMemory ByVal VarPtr(vpr), ByVal VarPtr(vt), 2&

        Dim si2 As IShellItem2
        Dim pps As IPropertyStore
        oleexp.SHCreateItemFromParsingName StrPtr(sMP3), Nothing, IID_IShellItem2, si2
        
        si2.GetPropertyStore GPS_OPENSLOWITEM Or GPS_READWRITE, IID_IPropertyStore, pps
        If (pps Is Nothing) = False Then
            Dim hr As Long
            hr = pps.SetValue(PKEY_ThumbnailStream, vpr)
            If hr <> S_OK Then
                WriteCover = hr
                Exit Function
            End If
            hr = 0
            'Title is easy by comparison. You can write any other string ID3 tags
            'that have a PKEY in Windows as well (see mPKEY.bas or propkey.h)
            If sTitle <> "" Then
                hr = pps.SetValue(PKEY_Music_AlbumTitle, CVar(sTitle))
                If hr <> S_OK Then
                    WriteCover = hr
                    Exit Function
                End If
                hr = 0
            End If
            hr = pps.Commit()
            WriteCover = hr
        End If
        GlobalFree hGG
        CloseHandle hFile
    End If
End If
End Function

---

* - I tried writing the APIC tag in clsID3v2 but I just couldn't get it to write without a couple bytes elsewhere in the tag getting corrupted and breaking the tag.

---

twinBASIC 64bit compatible version at https://github.com/fafalone/MiscDemos

[fafalone]

Other Notes

To read the cover image, you do something like this:

Dim si2 As IShellItem2
Dim vProp As Variant, vrProp As Variant


oleexp.SHCreateItemFromParsingName StrPtr(sMP3), Nothing, IID_IShellItem2, si2
If (si2 Is Nothing) = False Then
    si2.GetProperty PKEY_ThumbnailStream, vProp
    PropVariantToVariant vProp, vrProp
    If VarType(vrProp) = vbDataObject Then
        HBITMAP = hBitmapFromStream(vrProp)
    Else
        Debug.Print "No thumbstream found, VT=" & VarType(vrProp), 2
    End If
Else
    Debug.Print "Failed to create IShellItem2", 2
End If

'with
Private Function hBitmapFromStream(ByVal ImageSteam As oleexp.IStream) As Long
    Dim GdipBitmap As Long
    Dim hBitmap As Long 'GDI Bitmap handle.

    If gdipInitToken Then
        If GdipCreateBitmapFromStream(ImageSteam, GdipBitmap) = 0 Then 'GDIP_OK Then
            If GdipCreateHBITMAPFromBitmap(GdipBitmap, hBitmap, 0) = 0 Then 'GDIP_OK Then
                hBitmapFromStream = hBitmap
            Else
                Debug.Print "hBitmapFromStream failed at hbmpfrombmp|"
            End If
        Else
            Debug.Print "hBitmapFromStream failed at bmpFromStream"
        End If
    Else
        Debug.Print "GDIP not initialized"
    End If

End Function

That's the general idea to get an HBITMAP you can then display wherever.

You can use the same GetProperty call to read the string ID3 tags; just use a Variant then CStr().

[LeandroA]

Thanks for sharing, I researched a little more and found other keys to recover other data so I decided to put together a class module, it works fine, but in some cases "I think" that when the items are empty they may not be written correctly.

I share here the class module accompanied by an example.



Mp3 Tag Editor.zip

[fafalone]

You might need to check the types in those cases... like Track Number takes a 4-byte unsigned integer, not a string, so there may be a problem related to something like that. So you'd want at least CVar on a Long instead of a string, but to be sure I change it to unsigned since the PROPVARIANT data type need not be supported in VB to be passed to the property store; you can use PropVariantChangeType and convert the Variant to VT_UI4.

Very nice work.


Edit- Just a small side note, prefixing API calls like oleexp.SHCreateItemFromParsingName is just to avoid conflicts, like in case in some other module you had Public Declare Function SHCreateItemFromParsingName and the declare differed (in this case, ByVal pbc As Long or As Any is sometimes used instead of pbc As IBindCtx). In that case a plain call would go to the module as modules are higher priority than TLBs. It's not mandatory, so you need only prefix API calls with oleexp. if you're expecting conflicts.

[Lompin]

I have used the 'Modern Shell Interface' with the class 'ClsID3' and 'oleexp.tlb' to extract the Itags from
the Mp3 files, but unfortunately it is extremely slow when I want to extract more than 10,000 files
the Itag information and then save it in a database of data.

To have an idea to obtain the Itag of about 7,500 files it took approximately 18min. I would like to know if something can be done faster.

Since for each Itag extraction (Title, Album, etc ..) the 'LoadFile' Function is called, reopening the files for each Itag that we want to extract.
Thanks.

'FCnt = Total MP3 files found 
For i = 1 To FCnt
   With cID3
      RutaSong = Trim(F(i))
           If .LoadFile(RutaSong) = True Then   'Call class
                List1.AddItem .title
          End if
  End With 
Next

[fafalone]

I looked at the class and it's reading each value with a IShellItem2.GetProperty call, so for each file it's opening and closing the property store over a dozen times.

Instead, create an IPropertyStore object in loadfile, use IShellItem2.GetPropertyStore (or even better, GetPropertyStoreForKeys, which opens a limited store for only the PKEYs specified), and read the properties from that. Or, if you only need the title, just read that (you can keep using .GetProperty if it's just a single prop)-- the class is reading image data, that's going to slow it down quite a bit if your mp3s have art in them. But every unneeded tag slows it down.

[Lompin]

Hello,

uffffff is very complicate, I've been this morning and there's no way.
I have modified the 'LoadFile' function with the following code, which I don't know how to load the 'PKeys' in the call to 'PSGetPropertyDescription' on ????????

Public Function LoadFile(ByVal sPath As String) As Boolean
   On Error GoTo ErrItags

    Dim pps As IPropertyStore
    Dim psi As IShellItem2
    Dim i As Long
    Dim pProp As IPropertyDescription
    Dim lpProp As Long
    Dim sProp As String
    Dim PkeyPro As Integer

    Call SHCreateItemFromParsingName(StrPtr(sPath), ByVal 0&, IID_IShellItem2, si2)
    psi.GetPropertyStore GPS_DEFAULT Or GPS_BESTEFFORT Or GPS_OPENSLOWITEM, IID_IPropertyStore, pps
     With FrmMain
           PkeyPro = PKEY_Music_AlbumTitle : GoSub GetItagName: .List1.AddItem sProp  'Album
           PkeyPro = PKEY_Title : GoSub GetItagName: .List1.AddItem sProp  'Titulo
      .List1.AddItem "--------------------"
    End With

LoadFile = True
Exit Function

GetItagName:
       PSGetPropertyDescription ????????? , IID_IPropertyDescription, pProp
       PSFormatPropertyValue ObjPtr(pps), ObjPtr(pProp), PDFF_DEFAULT, lpProp
      sProp = BStrFromLPWStr(lpProp)
   Return


ErrItags:
   LoadFile = False
End Function

My Pkeys:

Private Const PKEY_ThumbnailStream = "{F29F85E0-4FF9-1068-AB91-08002B27B3D9},27"
Private Const PKEY_Music_Artist = "{56A3372E-CE9C-11D2-9F0E-006097C686F6}, 2"
Private Const PKEY_Title = "{F29F85E0-4FF9-1068-AB91-08002B27B3D9},2"
Private Const PKEY_Music_AlbumTitle = "{56A3372E-CE9C-11D2-9F0E-006097C686F6}, 4"
Private Const PKEY_Media_Year = "{56A3372E-CE9C-11D2-9F0E-006097C686F6},5"
Private Const PKEY_Audio_VariableBitRate = "{e6822fee-8c17-4d62-823c-8e9cfcbd1d5c}, 100" 'If empty VBR=True
Private Const PKEY_Media_EncodedBy = "{64440492-4C8B-11D1-8B70-080036B11A03},36"
Private Const PKEY_Audio_ChannelCount = "{64440490-4C8B-11D1-8B70-080036B11A03},7"
Private Const PKEY_Music_Genre = "{56A3372E-CE9C-11D2-9F0E-006097C686F6},11"
Private Const PKEY_Media_Duration = "{64440490-4C8B-11D1-8B70-080036B11A03},3"
Private Const PKEY_Music_TrackNumber = "{56A3372E-CE9C-11D2-9F0E-006097C686F6},7"
Private Const PKEY_Audio_EncodingBitrate = "{64440490-4C8B-11D1-8B70-080036B11A03},4"
Private Const PKEY_Audio_SampleSize = "{64440490-4C8B-11D1-8B70-080036B11A03}, 6"
Private Const PKEY_Audio_SampleRate = "{64440490-4C8B-11D1-8B70-080036B11A03},5"
Private Const PKEY_Comment = "{F29F85E0-4FF9-1068-AB91-08002B27B3D9},6"



Private Function Load_PKey() As Boolean
 
 Dim P As Integer
  For P = 1 To 15
      ReDim Preserve PropKeyP(P)
        PropKeyP(P).Cover_ThumbnailStream = PKEY_ThumbnailStream
        PropKeyP(P).Music_Artist = PKEY_Music_Artist
        PropKeyP(P).Music_Title = PKEY_Title
        PropKeyP(P).Music_AlbumTitle = PKEY_Music_AlbumTitle
        PropKeyP(P).Media_Year = PKEY_Media_Year
        PropKeyP(P).Audio_VariableBitRate = PKEY_Audio_VariableBitRate
        PropKeyP(P).Media_EncodedBy = PKEY_Media_EncodedBy
        PropKeyP(P).Audio_ChannelCount = PKEY_Audio_ChannelCount
        PropKeyP(P).Music_Genre = PKEY_Music_Genre
        PropKeyP(P).Media_Duration = PKEY_Media_Duration
        PropKeyP(P).Music_TrackNumber = PKEY_Music_TrackNumber
        PropKeyP(P).Audio_EncodingBitrate = PKEY_Audio_EncodingBitrate
        PropKeyP(P).Audio_SampleSize = PKEY_Audio_SampleSize
        PropKeyP(P).Audio_SampleRate = PKEY_Audio_SampleRate
        PropKeyP(P).Music_Comment = PKEY_Comment
 Next
   Load_PKey = True
End Function

Thank you.

[fafalone]

You have to pass a PROPERTYKEY type to PSGetPropertyDescription, not a string.

Private Sub DEFINE_PROPERTYKEY(Name As PROPERTYKEY, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte, pid As Long)
  With Name.fmtid
    .Data1 = L: .Data2 = w1: .Data3 = w2: .Data4(0) = B0: .Data4(1) = b1: .Data4(2) = b2: .Data4(3) = B3: .Data4(4) = b4: .Data4(5) = b5: .Data4(6) = b6: .Data4(7) = b7
  End With
  Name.pid = pid
End Sub

Private Function tPKEY_Music_AlbumTitle() As PROPERTYKEY
Static pkk As PROPERTYKEY
 If (pkk.fmtid.Data1 = 0&) Then Call DEFINE_PROPERTYKEY(pkk, &H56A3372E, &HCE9C, &H11D2, &H9F, &HE, &H0, &H60, &H97, &HC6, &H86, &HF6, 4)
tPKEY_Music_AlbumTitle = pkk
End Function

then

Private Declare Function PSGetPropertyDescription Lib "propsys.dll" (PropKey As oleexp.PROPERTYKEY, riid As oleexp.UUID, ppv As Any) As Long

PSGetPropertyDescription tPKEY_Music_AlbumTitle, IID_IPropertyDescription, pProp

I put a t in front of it so it doesn't conflict with your existing code there.


-

Can you clarify exactly what you're trying to and what keys you need? Can probably write up the quickest way to do it.

[fafalone]

Here's a barebones routine to read PKEY_Title and PKEY_Music_AlbumTitle like you're doing.

This will be about as fast as gets before you have to start going for extremes (you can look at my ucShellBrowse project... it will open a folder of thousands of mp3s with titles/albums displayed in a second; but loads album/title on demand instead of all at once.

Private Sub Command1_Click()

Dim siPath As IShellItem
Dim siChild As IShellItem, si2 As IShellItem2
Dim sTitle As String
Dim sAlbum As String
Dim sFile As String
Dim sOut As String
Dim pEnum As IEnumShellItems
Dim pc As Long
Dim vpv As Variant, vbv As Variant
Dim pps As IPropertyStore
Dim tPK() As PROPERTYKEY
ReDim tPK(2)
oleexp.SHCreateItemFromParsingName StrPtr(Text1.Text), Nothing, IID_IShellItem, siPath
If (siPath Is Nothing) Then
    Debug.Print "Invalid path."
    Exit Sub
End If

tPK(0) = PKEY_FileName
tPK(1) = PKEY_Title
tPK(2) = PKEY_Music_AlbumTitle

siPath.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, pEnum
Do While pEnum.Next(1&, siChild, pc) = S_OK
    If (siChild Is Nothing) = False Then
        Set si2 = siChild
        si2.GetPropertyStoreForKeys tPK(0), UBound(tPK) + 1&, GPS_OPENSLOWITEM Or GPS_BESTEFFORT, IID_IPropertyStore, pps
        If (pps Is Nothing) = False Then
            pps.GetValue PKEY_Title, vpv
            PropVariantToVariant vpv, vbv
            sTitle = CStr(vbv)
            pps.GetValue PKEY_Music_AlbumTitle, vpv
            PropVariantToVariant vpv, vbv
            sAlbum = CStr(vbv)
            pps.GetValue PKEY_FileName, vpv
            PropVariantToVariant vpv, vbv
            sFile = CStr(vbv)
            sOut = sFile & " Title=" & sTitle & ",Album=" & sAlbum
            List1.AddItem sOut
        End If
    End If
    Set si2 = Nothing
    Set siChild = Nothing
Loop

End Sub

As you can see, it uses the GetPropertyStoreForKeys method to get a limited-purpose PropertyStore with only the items we're interested, instead a store were you can access any property.

If you want to add another tag to read, add the PROPERTYKEY to tPK. The keys have to actual PROPERTYKEY structures though, not strings. See Module1.bas in the project. If you never want to have to worry about defining Property Keys, oleexp.tlb comes with a module called mPKEY.bas with all general purpose keys-- you can add the module, and only what you use will be compiled into your project, not the whole thing.

Using the PROPERTYKEY type:

Public Sub DEFINE_PROPERTYKEY(Name As PROPERTYKEY, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte, pid As Long)
  With Name.fmtid
    .Data1 = L: .Data2 = w1: .Data3 = w2
    .Data4(0) = B0: .Data4(1) = b1: .Data4(2) = b2: .Data4(3) = B3: .Data4(4) = b4: .Data4(5) = b5: .Data4(6) = b6: .Data4(7) = b7
  End With
  Name.pid = pid
End Sub

Public Function PKEY_Music_AlbumTitle() As PROPERTYKEY
Static pkk As PROPERTYKEY
 If (pkk.fmtid.Data1 = 0&) Then Call DEFINE_PROPERTYKEY(pkk, &H56A3372E, &HCE9C, &H11D2, &H9F, &HE, &H0, &H60, &H97, &HC6, &H86, &HF6, 4)
PKEY_Music_AlbumTitle = pkk
End Function

and they go on like that in module, with something similar for IID_ values.

Saves you from having to convert string to GUID then GUID+PID to PROPERTYKEY.

Regarding PKEY_ThumbnailStream... that's the cover image, JPG or PNG... you really don't want to pre-load 7,500 of these... you can't display that many at once unless you've got like a giant video wall, and might have memory issues. Load them on demand.

[Lompin]

Thank you,
I've been modifying my program so you can see what you think and if it can be improved.
Now it is much faster, to read the Itags that interest me it takes about 2 minutes instead of 18 minutes that it used to take to read 7.841 music files, we have improved a lot.

I have been testing your program and it disappears or there is something that makes the system close it.
Now I will see it in more depth, there is something that I do not understand much, I will tell you.


Attachment 181163

Greetings.

[Lompin]

Hello,

I have been examining the code and it fails on this line:

        si2.GetPropertyStoreForKeys tPK(0), UBound(tPK) + 1&, GPS_OPENSLOWITEM Or GPS_BESTEFFORT, IID_IPropertyStore, pps

Modify the code above a bit because it only read the files in the main folder and not the subfolders and the code looked like this.

Dim Itags As ClsItags
si2 As IShellItem2
Dim sTitle As String
Dim sAlbum As String
Dim sYear As String
Dim sOut As String
Dim pEnum As IEnumShellItems
Dim pc As Long
Dim vpv As Variant, vbv As Variant
Dim pps As IPropertyStore
Dim tPK() As PROPERTYKEY
Dim F() As String
Dim FCnt As Long
Dim i As Long
Dim IDir As String

ReDim tPK(2)

tPK(0) = tPKEY_Music_Title
tPK(1) = tPKEY_Music_AlbumTitle
tPK(2) = tPKEY_Media_Year


IDir = "F:\JoyingCar"

EnumFiles IDir, F, FCnt, "*.mp3*;* ", True

For i = 1 To FCnt
   DoEvents
 
      oleexp.SHCreateItemFromParsingName StrPtr(Trim(F(i))), Nothing, IID_IShellItem2, si2
     ' Call SHCreateItemFromParsingName(StrPtr(fPath), ByVal 0&, IID_IShellItem2, si2)

 
       ProgressBar1.Value = i
        Label2.Caption = "Total Files: " & Format(FCnt, "##,##") & "/" & Format(i, "##,##")

        si2.GetPropertyStoreForKeys tPK(0), UBound(tPK) + 1&, GPS_OPENSLOWITEM Or GPS_BESTEFFORT, IID_IPropertyStore, pps
          If (pps Is Nothing) = False Then
            pps.GetValue tPKEY_Music_Title, vpv
            PropVariantToVariant vpv, vbv
            sTitle = CStr(vbv)
            pps.GetValue tPKEY_Music_AlbumTitle, vpv
            PropVariantToVariant vpv, vbv
            sAlbum = CStr(vbv)
            pps.GetValue tPKEY_Media_Year, vpv
            PropVariantToVariant vpv, vbv
            syear = CStr(vbv)
            sOut = "Album=" & sAlbum & "|Title=" & sTitle & " " & sYear
            List1.AddItem sOut
        End If
         Set si2 = Nothing
Next

I don't know how I can upload the file with the program?

[xiaoyao]

thank you,
i've been modifying my program so you can see what you think and if it can be improved.
Now it is much faster, to read the itags that interest me it takes about 2 minutes instead of 18 minutes that it used to take to read 7.841 music files, we have improved a lot.

I have been testing your program and it disappears or there is something that makes the system close it.
Now i will see it in more depth, there is something that i do not understand much, i will tell you.


Attachment 181163

greetings.

download link err?

[fafalone]

The code is failing how? On all files, certain files?

Trying adding the GPS_DEFAULT flag.

[Lompin]

Hello,

By setting 'Set pps = Nothing' the program does not exit or overflow, it seems to be going well.

Dim Itags As ClsItags
si2 As IShellItem2
Dim sTitle As String
Dim sAlbum As String
Dim sYear As String
Dim sOut As String
Dim pc As Long
Dim vpv As Variant, vbv As Variant
Dim pps As IPropertyStore
Dim tPK() As PROPERTYKEY
Dim F() As String
Dim FCnt As Long
Dim i As Long
Dim IDir As String

ReDim tPK(2)

tPK(0) = tPKEY_Music_Title
tPK(1) = tPKEY_Music_AlbumTitle
tPK(2) = tPKEY_Media_Year


IDir = "F:\JoyingCar"

EnumFiles IDir, F, FCnt, "*.mp3*;* ", True

For i = 1 To FCnt
   DoEvents
 
      oleexp.SHCreateItemFromParsingName StrPtr(Trim(F(i))), Nothing, IID_IShellItem2, si2
     ' Call SHCreateItemFromParsingName(StrPtr(fPath), ByVal 0&, IID_IShellItem2, si2)

 
       ProgressBar1.Value = i
        Label2.Caption = "Total Files: " & Format(FCnt, "##,##") & "/" & Format(i, "##,##")

        si2.GetPropertyStoreForKeys tPK(0), UBound(tPK) + 1&, GPS_OPENSLOWITEM Or GPS_BESTEFFORT, IID_IPropertyStore, pps
          If (pps Is Nothing) = False Then
            pps.GetValue tPKEY_Music_Title, vpv
            PropVariantToVariant vpv, vbv
            sTitle = CStr(vbv)
            pps.GetValue tPKEY_Music_AlbumTitle, vpv
            PropVariantToVariant vpv, vbv
            sAlbum = CStr(vbv)
            pps.GetValue tPKEY_Media_Year, vpv
            PropVariantToVariant vpv, vbv
            syear = CStr(vbv)
            sOut = "Album=" & sAlbum & "|Title=" & sTitle & " " & sYear
            List1.AddItem sOut
        End If

         Set pps= Nothing       '<<<<<<<
          Set si2 = Nothing
Next

[Lompin]

Hello,

I would like to know the difference in putting 'GPS_DEFAULT Or GPS_FASTPROPERTIESONLY' and GPS_DEFAULT Or GPS_BESTEFFORT to the 'GetPropertyStoreForKeys' call.

The first one only reads the extensions files, Artist Name, Title and Album all empty, that if it goes super fast but without results.
The second reads all the keys I have nothing to say.

Too bad it does not read as fast as the first one would be luxurious.

Thanks

[fafalone]

the 'Fast properties only' does exactly as it suggests-- only read the properties it can retrieve fast. If it has to load a property handler, that's going to be slow, and for things like mp3 properties, office documents, etc, those use a property handler. best effort tells it to return a property store even if all requested properties aren't available. Here's a page describing all the flags:

https://docs.microsoft.com/en-us/win...ertystoreflags

[Lompin]

Hello,

By entering this 'PKEY_Music_Artist' and 'PKEY_Music_Genre' in your code 'FastReadMP3'
It gives me the Error '13 - The types do not match 'and I don't understand, let's see if you can verify it. Thanks.

I have added this:


Module Bas:

Public Function PKEY_Music_Artist() As PROPERTYKEY
Static pkk As PROPERTYKEY
 If (pkk.fmtid.Data1 = 0&) Then Call DEFINE_PROPERTYKEY(pkk, &H56A3372E, &HCE9C, &H11D2, &H9F, &HE, &H0, &H60, &H97, &HC6, &H86, &HF6, 2)
PKEY_Music_Artist = pkk
End Function

Public Function PKEY_Music_Genre() As PROPERTYKEY
Static pkk As PROPERTYKEY
 If (pkk.fmtid.Data1 = 0&) Then Call DEFINE_PROPERTYKEY(pkk, &H56A3372E, &HCE9C, &H11D2, &H9F, &HE, &H0, &H60, &H97, &HC6, &H86, &HF6, 11)
 PKEY_Music_Genre = pkk
End Function

In 'Go Button'

Dim siPath As IShellItem
Dim siChild As IShellItem, si2 As IShellItem2
Dim sAlbum As String
Dim sArtist As String
Dim SGenre as String
Dim sOut As String
Dim pEnum As IEnumShellItems
Dim pc As Long
Dim vpv As Variant, vbv As Variant
Dim pps As IPropertyStore
Dim tPK() As PROPERTYKEY

ReDim tPK(3)

oleexp.SHCreateItemFromParsingName StrPtr(Text1.Text), Nothing, IID_IShellItem, siPath
If (siPath Is Nothing) Then
    Debug.Print "Invalid path."
    Exit Sub
End If

tPK(0) = PKEY_Title
tPK(1) = PKEY_Music_Artist
tPK(2) = PKEY_Music_AlbumTitle
tPK(3) = PKEY_Music_Genre

siPath.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, pEnum
Do While pEnum.Next(1&, siChild, pc) = S_OK
   DoEvents
    If (siChild Is Nothing) = False Then
        Set si2 = siChild
        si2.GetPropertyStoreForKeys tPK(0), UBound(tPK) + 1&, GPS_DEFAULT Or GPS_BESTEFFORT, IID_IPropertyStore, pps
        If (pps Is Nothing) = False Then
            
            pps.GetValue PKEY_Title, vpv
            PropVariantToVariant vpv, vbv
            sTitle = CStr(vbv)
            
            pps.GetValue PKEY_Music_Artist, vpv
            PropVariantToVariant vpv, vbv
            sArtist = CStr(vbv)                                  '<<<<<<<<<<< Here Error '13'
            
            pps.GetValue PKEY_Music_Genre, vpv
            PropVariantToVariant vpv, vbv
            sGenre = CStr(vbv)                                 '<<<<<<<<<<< Here Error '13'

            pps.GetValue PKEY_Music_AlbumTitle, vpv
            PropVariantToVariant vpv, vbv
            sAlbum = CStr(vbv)
            
            sOut = "Title=" & sTitle & ",Artist=" & sArtist & ",Album=" & sAlbum & ",Genre=" & sGenre
            List1.AddItem sOut
        End If
    End If
    Set si2 = Nothing
    Set siChild = Nothing
    Set pps = Nothing
    
Loop
Beep
Erase tPK

Thx.

[fafalone]

If you Google the keys and look at Microsoft's entry for them, you find that both PKEY_Music_Artist ('Contributing Artists') and PKEY_Music_Genre ('Genres') are listed as 'Multivalue string' for their type: This means they're string arrays, so you have to read each element:

Dim i As Long
Dim sArtist As String
Dim sGenre As String
'...

            sArtist = ""
            pps.GetValue PKEY_Music_Artist, vpv
            PropVariantToVariant vpv, vbv
            Dim i As Long
            For i = 0 To UBound(vbv)
                sArtist = sArtist & CStr(vbv(i)) & "; "
            Next i

            sGenre = ""
            pps.GetValue PKEY_Music_Genre, vpv
            PropVariantToVariant vpv, vbv
            For i = 0 To UBound(vbv)
                sGenre = sGenre & CStr(vbv(i)) & "; "
            Next i

I've written a more robust method that automatically handles whatever type a key is and returns a string, if you're willing to incur a minor performance penalty:

Private Declare Function PSGetPropertyDescription Lib "propsys.dll" (PropKey As oleexp.PROPERTYKEY, riid As oleexp.UUID, ppv As Any) As Long
Private Declare Function PSFormatPropertyValue Lib "propsys.dll" (ByVal pps As Long, ByVal ppd As Long, ByVal pdff As PROPDESC_FORMAT_FLAGS, ppszDisplay As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long

Private Function GetPropertyKeyDisplayString(pps As oleexp.IPropertyStore, pkProp As oleexp.PROPERTYKEY, Optional bFixChars As Boolean = True) As String
'Gets the string value of the given the PROPERTYKEY: See mPKEY.bas/propkey.h
'This would be the value displayed in Explorer if you added the column in details view

On Error GoTo e0

Dim lpsz As Long
Dim ppd As oleexp.IPropertyDescription
If ((pps Is Nothing) = False) Then
    PSGetPropertyDescription pkProp, IID_IPropertyDescription, ppd
    If (ppd Is Nothing) Then
        Dim vrr As Variant, vbr As Variant
        pps.GetValue pkProp, vrr
        PropVariantToVariant vrr, vbr
        If (VarType(vbr) And vbArray) = vbArray Then
            Dim i As Long
            For i = LBound(vbr) To UBound(vbr)
                GetPropertyKeyDisplayString = GetPropertyKeyDisplayString & CStr(vbr(i)) & "; "
            Next i
            If Len(GetPropertyKeyDisplayString) > 2 Then
                GetPropertyKeyDisplayString = Left$(GetPropertyKeyDisplayString, Len(GetPropertyKeyDisplayString) - 2)
            End If
        Else
            GetPropertyKeyDisplayString = CStr(vbr)
        End If
    Else
        Dim hr As Long
        hr = PSFormatPropertyValue(ObjPtr(pps), ObjPtr(ppd), PDFF_DEFAULT, lpsz)
        SysReAllocString VarPtr(GetPropertyKeyDisplayString), lpsz
        CoTaskMemFree lpsz
    End If
    If bFixChars Then
        GetPropertyKeyDisplayString = Replace$(GetPropertyKeyDisplayString, ChrW$(&H200E), "")
        GetPropertyKeyDisplayString = Replace$(GetPropertyKeyDisplayString, ChrW$(&H200F), "")
        GetPropertyKeyDisplayString = Replace$(GetPropertyKeyDisplayString, ChrW$(&H202A), "")
        GetPropertyKeyDisplayString = Replace$(GetPropertyKeyDisplayString, ChrW$(&H202C), "")
    End If
    Set ppd = Nothing
Else
    Debug.Print "GetPropertyKeyDisplayString.Error->PropertyStore is not set."
End If

Exit Function

e0:
    Debug.Print "GetPropertyKeyDisplayString->Error: " & Err.Description & ", 0x" & Hex$(Err.Number)
End Function

Private Function IID_IPropertyDescription() As oleexp.UUID
'(IID_IPropertyDescription, 0x6f79d558, 0x3e96, 0x4549, 0xa1,0xd1, 0x7d,0x75,0xd2,0x28,0x88,0x14
Static iid As oleexp.UUID
 If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H6F79D558, CInt(&H3E96), CInt(&H4549), &HA1, &HD1, &H7D, &H75, &HD2, &H28, &H88, &H14)
  IID_IPropertyDescription = iid
End Function

[Hank-15]

Hello, I wanted to know how to insert just the image into an mp3.

With 2 Fileboxes

Private Sub Form_Load()
FileMP3.Path = App.Path & "\Moti Special\Dancing For Victory 1990"
FileCover.Path = App.Path & "\Moti Special\Dancing For Victory 1990"
End Sub

Sorry my English not the best but Thank you in advanced

[Arnoutdv]

Did you check the class from post #3?
https://www.vbforums.com/showthread....=1#post5428963

[fafalone]

Just a barebones 'write the image' is what the code in my original post to start this thread does.

WriteCover FileCover.Path & "\" & FileCover.FileName, FileMP3.Path & "\" & FileMP3.FileName

[-Franky-]

You could also shorten the whole thing a bit. It's from a test project and as always without TLB.

Public Function WriteMp3Image(ByVal Mp3File As String, _
                              ByVal ImageFile As String) As Boolean
    Dim Ret As Boolean
    Dim pIPropertyStore As Long
    If SHGetPropertyStoreFromParsingName(StrPtr(Mp3File), 0&, GPS_READWRITE, _
                                         Str2Guid(IID_IPropertyStore), _
                                         pIPropertyStore) = S_OK Then
        Dim pIStream As Long
        If SHCreateStreamOnFile(StrPtr(ImageFile), STGM_READ, pIStream) = S_OK Then
            Dim tPROPERTYKEY As PROPERTYKEY
            With tPROPERTYKEY
                .fmtid = Str2Guid(PKEY_ThumbnailStream_Guid)
                .pid = PKEY_ThumbnailStream_Pid
            End With
            Dim tPROPVARIANT As PROPVARIANT
            With tPROPVARIANT
                .vt = VT_STREAM
                .vData0 = pIStream
            End With
            If InvokeIfc(pIPropertyStore, IPropertyStore_SetValue, _
                         VarPtr(tPROPERTYKEY), VarPtr(tPROPVARIANT)) = S_OK Then
                If InvokeIfc(pIPropertyStore, IPropertyStore_Commit) = S_OK Then
                    Ret = True
                End If
            End If
            Call ReleaseIfc(pIStream)
        End If
        Call ReleaseIfc(pIPropertyStore)
    End If
    WriteMp3Image = Ret
End Function

[fafalone]

That's an interesting definition of "shorten", hiding code in other functions

To shorten your shorten method,

Public Function WriteMp3Image(ByVal Mp3File As String, _
                              ByVal ImageFile As String) As Boolean
    On Error GoTo out
    Dim Ret As Boolean
    Dim pIPropertyStore As IPropertyStore
     SHGetPropertyStoreFromParsingName StrPtr(Mp3File), 0&, GPS_READWRITE, _
                                         IID_IPropertyStore, _
                                         pIPropertyStore 
    If (pIPropertyStore Is Nothing) = False Then
        Dim pIStream As IStream
         SHCreateStreamOnFile StrPtr(ImageFile), STGM_READ, pIStream 
        If (pIStream Is Nothing) = False Then
             pIPropertyStore.SetValue PKEY_ThumbnailStream, pIStream
            ret = True
        End If
    End If
out:
    WriteMp3Image = Ret
End Function

No need for the crazy InvokeIfc stuff, manually freeing, PROPVARIANT UDTs, String2Guid, and bespoke vtable enums and GUIDs. Just the standard oleexp and its standard addon modules (or copying fewer lines from them than the total in non-boilerplate code from the original)

[Schmidt]

That's an interesting definition of "shorten", hiding code in other functions

...

Just the standard oleexp and its standard addon modules...

same difference...

Olaf

[fafalone]

Yes we're splitting hairs and playing with definitions, welcome to the party

But I think there is a slight difference between "copy and paste this specific code" and "check the box/click add for reference". Surely an RC6-based solution wouldn't expect us to count the (unknowable) full method lengths inside the vbRichClient DLL.

[-Franky-]

It's not about splitting hairs or whether to use a TLB or not. What I mean is, look at your code from #1 and now. It's a lot shorter.

[Hank-15]

Hello LeandroA
I have a question. I want to hide a label when no image is displayed and display the label when an image is displayed. But how...

Thank you in andvance ?

[Hank-15]

Thank you ?

[fafalone]

The open command already does a simple test to see if there's an image or not; it should be pretty obvious how to put a LabelWhatever.Visible = True/False around this...

        If VarType(.ThumbnailStream) <> vbEmpty Then
            PaintPictureFromArrData .ThumbnailData, Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight
        End If

.Visible = False at the start of the Sub and = True only inside that block.

[Hank-15]

The open command already does a simple test to see if there's an image or not; it should be pretty obvious how to put a LabelWhatever.Visible = True/False around this...

        If VarType(.ThumbnailStream) <> vbEmpty Then
            PaintPictureFromArrData .ThumbnailData, Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight
        End If

.Visible = False at the start of the Sub and = True only inside that block.

Thank you
but I still have a problem. I want the tags to be entered into several mp3s with a timer or for next loop



Private Sub InfoSave()
sFileMP3 = FileMP3.Path & "" & FileMP3.FileName
With cID3
.Title = TxtTitle.Text
.Artist = Split(LblInfo(0).Caption, "//")
.AlbumTitle = LblInfo(1).Caption
.Year = IIf(Val(LblInfo(2).Caption) > 0, Val(LblInfo(2).Caption), Empty)
If .WriteFile Then
Beep
Else
MsgBox "Error"
End If
End With
TxtInfo.Visible = False: TxtInfo.Text = "": LblSave.Visible = False
End Sub


Private Sub TSave_Timer()
tis = tis + 1
FileMP3.ListIndex = tis - 1
Call InfoSave
If tis = FileMP3.ListCount Then TSave.Enabled = False: tis = 0
End Sub


this only works in the first mp3 then no longer

Could you help me please
Thank you in advance for your response ?

[fafalone]

You can remove the timer and wrap it in a loop like

Dim i As Long
For i = 0 To FileMP3.ListCount - 1
    sFileMP3 = FileMP3.Path & "\" & FileMP3.List(i)
...
Next

[Hank-15]

Private Sub LblSave_Click()
 Dim lis As Long
 For lis = 0 To FileMP3.ListCount - 1
  sFileMP3 = FileMP3.Path & "\" & FileMP3.List(lis)
  With cID3
      '.Title = TxtTitle.Text
      .Artist = Split(LblInfo(0).Caption, "//")
      .AlbumTitle = LblInfo(1).Caption
      .Year = IIf(Val(LblInfo(2).Caption) > 0, Val(LblInfo(2).Caption), Empty)
   If .WriteFile Then
       Beep
   Else
       MsgBox "Error"
   End If
  End With
  TxtInfo.Visible = False: TxtInfo.Text = "": LblSave.Visible = False
 Next
End Sub

Even so, only the first mp3 is written. What else am I doing wrong? ??

[fafalone]

You're not loading the new file into cID3.

Private Sub LblSave_Click()
 Dim lis As Long
 If (cID3 Is Nothing) = False Then Set cID3 = Nothing 'close any open file
 For lis = 0 To FileMP3.ListCount - 1
  sFileMP3 = FileMP3.Path & "\" & FileMP3.List(lis)
  Set cID3 = New clsID3
  With cID3
      If .LoadFile(sFileMP3) Then
      '.Title = TxtTitle.Text
      .Artist = Split(LblInfo(0).Caption, "//")
      .AlbumTitle = LblInfo(1).Caption
      .Year = IIf(Val(LblInfo(2).Caption) > 0, Val(LblInfo(2).Caption), Empty)
   If .WriteFile Then
       Beep
   Else
       MsgBox "Error"
   End If
   End If
  End With
  Set cID3 = Nothing
  TxtInfo.Visible = False: TxtInfo.Text = "": LblSave.Visible = False
 Next
End Sub

[Hank-15]

You're not loading the new file into cID3.

Private Sub LblSave_Click()
 Dim lis As Long
 If (cID3 Is Nothing) = False Then Set cID3 = Nothing 'close any open file
 For lis = 0 To FileMP3.ListCount - 1
  sFileMP3 = FileMP3.Path & "\" & FileMP3.List(lis)
  Set cID3 = New clsID3
  With cID3
      If .LoadFile(sFileMP3) Then
      '.Title = TxtTitle.Text
      .Artist = Split(LblInfo(0).Caption, "//")
      .AlbumTitle = LblInfo(1).Caption
      .Year = IIf(Val(LblInfo(2).Caption) > 0, Val(LblInfo(2).Caption), Empty)
   If .WriteFile Then
       Beep
   Else
       MsgBox "Error"
   End If
   End If
  End With
  Set cID3 = Nothing
  TxtInfo.Visible = False: TxtInfo.Text = "": LblSave.Visible = False
 Next
End Sub

thank you very much it works

[fafalone]

Hey can anyone tell me their experience of using this demo on Windows 10?

This worked fine on 7 but today I tried it on 10 for the first time, and it just blanked out the entire id3 tag. Mp3Tag indicated it was still present, just all the fields were now blank, even those my program doesn't touch.

Then I found the same thing happens if I try to edit a tag in Explorer... so it's not my code, it's the handler itself.

If I edit a second time, it correctly sets the new fields, but the original ones remain blank.

Looking to at least see if this is a 'my computer' problem or a common Windows 10/11 problem... so if anyone could give it a quick try.. would be appreciated.


Note: I did try compiling a 64bit version too, no difference. You can check it out here but note I started to add some other features and didn't finish them, just updated the VB6 code... https://github.com/fafalone/MP3Cover

[VanGoghGaming]

I didn't know Explorer could edit MP3 properties but it does work fine in both Windows 10 and 11. Your code also works fine, the JPG is added successfully and also the album title is changed correctly. Explorer also shows these changes so I don't know what's wrong with yours.

This compacted version also works correctly (using your recent fix of "SHCreateMemStream"):

    Private Function WriteCover(sJPG As String, sMP3 As String, Optional sTitle As String) As Long
    Dim vpr As Variant, oStrm As IStream, baData() As Byte, si2 As IShellItem2, pps As IPropertyStore
        With CreateObject("ADODB.Stream")
            .Type = 1: .Open: .LoadFromFile sJPG: baData = .Read
            Set oStrm = SHCreateMemStream(baData(0), .Size)
        End With
        CopyMemory vpr, VT_STREAM, 2: CopyMemory ByVal VarPtr(vpr) + 8, ObjPtr(oStrm), 4
        SHCreateItemFromParsingName StrPtr(sMP3), Nothing, IID_IShellItem2, si2
        si2.GetPropertyStore GPS_OPENSLOWITEM Or GPS_READWRITE, IID_IPropertyStore, pps
        If Not pps Is Nothing Then
            If pps.SetValue(PKEY_ThumbnailStream, vpr) = S_OK Then
                If Len(sTitle) Then pps.SetValue PKEY_Music_AlbumTitle, CVar(sTitle)
                pps.Commit
            End If
        End If
        WriteCover = Err.LastHresult
    End Function

[fafalone]

I see, thanks for testing it. Not the first time my Explorer has acted odd... Currently it's locked into elevated.

Ps- Couldn't you just Set vpr = oStrm then overwrite the type rather than manually copy the pointer (with a 64bit unfriendly hard coded pointer size no less?)

But there's an even more compact option I believe; SHCreateStreamOnFile.

[VanGoghGaming]

You could make CopyMemory 64bit-friendly by changing the "Length" parameter to "LenB(LongPtr)" but yeah, "Set" works the same provided you change the variant type to "VT_STREAM" afterwards.

Most compact version yet:

Private Function WriteCover(sJPG As String, sMP3 As String, Optional sTitle As String) As Long
Dim vpr As Variant, si2 As IShellItem2, pps As IPropertyStore
    Set vpr = SHCreateStreamOnFile(sJPG, STGM_READ)
    If Not IsEmpty(vpr) Then
        CopyMemory vpr, VT_STREAM, 2
        If SHCreateItemFromParsingName(StrPtr(sMP3), Nothing, IID_IShellItem2, si2) = S_OK Then
            si2.GetPropertyStore GPS_OPENSLOWITEM Or GPS_READWRITE, IID_IPropertyStore, pps
            If Not pps Is Nothing Then
                If pps.SetValue(PKEY_ThumbnailStream, vpr) = S_OK Then If Len(sTitle) Then pps.SetValue PKEY_Music_AlbumTitle, CVar(sTitle)
                pps.Commit
            End If
        End If
    End If
    WriteCover = Err.LastHResult
End Function