Transférer une icone de la barre d'outils vers word.

Sub ShowFaceIDs()
    Dim NewToolbar As CommandBar
    Dim TopPos As Long, LeftPos As Long
    Dim i As Long, NumPics As Long

'- - - - - Change These - - - - -
    Const ID_START As Long = 1
    Const ID_END As Long = 500
'- - - - - - - - - - - - - - - - - - - -

'   Delete existing TempFaceIds toolbar if it exists
    On Error Resume Next
    Application.CommandBars("TempFaceIds").Delete
    On Error GoTo 0

'   Clear the sheet
    ActiveSheet.Pictures.Delete
    Application.ScreenUpdating = False
    
'   Add an empty toolbar
    Set NewToolbar = Application.CommandBars.Add _
        (Name:="TempFaceIds")

'   Starting positions
    TopPos = 5
    LeftPos = 5
    NumPics = 0
    
    For i = ID_START To ID_END
        On Error Resume Next
        NewToolbar.Controls(1).Delete
        With NewToolbar.Controls.Add(Type:=msoControlButton)
            .FaceId = i
            .CopyFace
        End With
        On Error GoTo 0
        
        NumPics = NumPics + 1
        ActiveSheet.Paste
        With ActiveSheet.Shapes(NumPics)
            .Top = TopPos
            .Left = LeftPos
            .Name = "FaceID " & i
            .PictureFormat.TransparentBackground = True
            .PictureFormat.TransparencyColor = RGB(224, 223, 227)
        End With
        
'       Update top and left positions for the next one
        LeftPos = LeftPos + 16
        If NumPics Mod 40 = 0 Then
            TopPos = TopPos + 16
            LeftPos = 5
        End If
    Next i
    ActiveWindow.RangeSelection.Select
    Application.CommandBars("TempFaceIds").Delete
End Sub