XL 2021 VBA - Pourquoi les imageMso ne se conservent pas dans le tableau ?

Option Explicit

Sub ListeImageMso()
    Dim Tbl As ListObject
    Dim IPictureDisp As IPictureDisp
    Dim Shape As Shape
    Dim tempPath As String
    Dim RC As Integer
    Dim ErrNumber As Long
    Dim i As Long
   Application.ScreenUpdating = False
    'Tableau des imageMso
    Set Tbl = ThisWorkbook.Worksheets(1).ListObjects(1)
    
    For Each Shape In ActiveSheet.Shapes
        If Not Shape.Name = "Bouton" Then Shape.Delete
    Next Shape
    
    With Tbl
        For i = 1 To .ListRows.Count
            'Barre de progression
            RC = BarreProgression.Display("Touche <Entrée> pour interrompre", .ListRows.Count, i)
            
            If RC < 0 Then
                RC = MsgBox("Interruption demandée !" & vbCrLf & "Continuer ?", vbYesNo + vbQuestion)
                If RC = vbYes Then
                    Call BarreProgression.Continue
                End If
                
                If RC = vbNo Then
                    BarreProgression.Cancel
                    Exit Sub
                End If
            End If
            
            'Row Height
            ActiveSheet.Rows(.ListRows(i).Range.Row).RowHeight = 36
            
            ' Affiche l’icône
            On Error Resume Next
            Set IPictureDisp = CommandBars.GetImageMso(.ListColumns(1).DataBodyRange(i).Value, 32, 32)
            ErrNumber = Err.Number
            On Error GoTo 0
            
            If ErrNumber = 0 Then
                'tempPath = Environ("TEMP") & "\temp_logo.bmp"
               ' If Not Len(Dir(tempPath)) = 0 Then Kill tempPath
                'SavePicture IPictureDisp, tempPath
                
                Dim lbl As OLEObject
                Set lbl = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Label.1", _
                                                                 Left:=Tbl.DataBodyRange(i, 2).Left + 2, _
                                                                 Top:=Tbl.DataBodyRange(i, 2).Top + 2, _
                                                                 Width:=32, Height:=32)
                
                With lbl
                    .Name = "lblImg_" & i
                     .Object.Picture = CommandBars.GetImageMso(Tbl.ListColumns(1).DataBodyRange(i).Value, 32, 32)
                    .Object.PicturePosition = 12
                   .Object.Caption = ""
               End With
                
                'With ActiveSheet.Pictures.Insert(tempPath)
                    '.Left = Tbl.DataBodyRange(i, 2).Left + 2
                    '.Top = Tbl.DataBodyRange(i, 2).Top + 2
                    '.Width = 32
                    '.Height = 32
                'End With
            End If
            
            DoEvents
        Next i
    End With
End Sub