Export image avec une certaine taille en pixels

Bonjour,

Je viens faire appel à votre aide pour l'export d'images sur excel.

J'ai une macro qui me permet d'exporter des pictogrammes en JPG. Cela marche parfaitement, toutefois j'aimerais que la photo enregistrée soit un carré parfait de 1000 pixels par 1000 pixels.

J'ai beau modifier la taille, choisir une taille dans ma macro, la photo ne fait jamais 1000x1000 ...

Voici le code et le fichier (simplifié) :

Sub test()

Dim picto As Range, cell1 As Range, cell2 As Range

Dim cht As ChartObject
Dim ActiveShape As Shape
Dim Graph As Chart
Dim co As Byte, qty As Byte

Dim path As String

path = ThisWorkbook.path

co = 1

Set cell1 = Sheets("pictogrammes").[A1]

'Quantity of pictos:
qty = 4

Do While co <= qty

    Set cell2 = cell1.Offset(1)

    Set picto = Range(cell1.Address & ":" & cell2.Address)
    
    picto.Copy
    
    ActiveSheet.Pictures.Paste(link:=False).Select
      Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
      
    'Create a temporary chart object (same size as shape)
      Set cht = ActiveSheet.ChartObjects.Add( _
        Left:=ActiveCell.Left, _
        Width:=ActiveShape.Width, _
        Top:=ActiveCell.Top, _
        Height:=ActiveShape.Height)
        
    
    '2398.08153
    'Format temporary chart to have a transparent background
    ActiveWindow.DisplayGridlines = False
    cht.Chart.ChartArea.Format.Line.Visible = msoFalse
        
    'Copy/Paste Shape inside temporary chart
      ActiveShape.Copy
      cht.Activate
      ActiveChart.Paste
      
    
      
    'Save chart to User's Desktop as PNG File
    
    
    
      cht.Chart.Export path & "\picto n°" & co & ".jpg"
    
    'Delete temporary Chart
      cht.Delete
      ActiveShape.Delete


    co = co + 1
    
    Set cell1 = cell1.Offset(, 1)
    
Loop


End Sub

Et voici le fichier : https://wetransfer.com/downloads/967ac32001621516c374c4c0e68e91ff20220801154847/414b7e

Merci d'avance et bonne journée !