Creation de bar de menu

Bonjour,

Mon soucis aujourd'hui c'est que j'aimerais ajouter une image a chaque ligne de ma barre de menu en cascade de manière automatique .

voila mon code:

Sub ParamatreCreatePopUp()

    Dim CommandbarMenuSheet As Worksheet
    Dim CommandbarMenuItem As Object
    Dim CommandbarSubMenuItem As CommandBarButton
    Dim row As Long
    Dim MenuLevel, NextLevel, MacroName, Caption, Divider, FaceId
    Dim Img1 As String

   
    'Définit la dimension des images
    Home.ImageList1.ImageHeight = 16 'Hauteur
    Home.ImageList1.ImageWidth = 16 'Largeur
    
    Set CommandbarMenuSheet = Sheet1
   
    Call ParamatreRemovePopUp

   
    row = 5

    With Application.CommandBars.Add(Sheet1. _
                                     Range("B2").Value, msoBarPopup, False, True)

        Do Until IsEmpty(CommandbarMenuSheet.Cells(row, 1))
            With CommandbarMenuSheet
                MenuLevel = .Cells(row, 1)
                Caption = .Cells(row, 2)
                MacroName = .Cells(row, 3)
                Divider = .Cells(row, 4)
                FaceId = .Cells(row, 5)
                NextLevel = .Cells(row + 1, 1)
            End With
            
        Home.ImageList1.ListImages.Add , "FaceId", LoadPicture(ThisWorkbook.Path & FaceId)
        
        
            Select Case MenuLevel
            Case 2
                If NextLevel = 3 Then
                    Set CommandbarMenuItem = .Controls.Add(Type:=msoControlPopup)
                Else
                    Set CommandbarMenuItem = .Controls.Add(Type:=msoControlButton)
                     CommandbarMenuItem.OnAction = ThisWorkbook.Name & "!" & MacroName
                End If
                 CommandbarMenuItem.Caption = Caption
                If FaceId <> "" Then CommandbarMenuItem.Picture = Home.ImageList1.ListImages("FaceId").Picture 'FaceId
                If Divider Then CommandbarMenuItem.BeginGroup = True

            End Select
            row = row + 1
        Loop
    End With
End Sub

Sub ParamatreDisplayPopUp()
    If ActiveWorkbook.Name = ThisWorkbook.Name Then
        On Error Resume Next
        Application.CommandBars(Sheet1.Range("B2").Value).ShowPopup
        On Error GoTo 0
    End If
End Sub


Sub ParamatreRemovePopUp()
    On Error Resume Next
    Application.CommandBars(Sheet1.Range("B2").Value).Delete
    On Error GoTo 0
End Sub

https://drive.google.com/file/d/1o9TRYeZR1Jj3rkp9kRQI3PH9FRNNiO6T/view?usp=sharing