Sub Insère_ImageDansCellule_V2020_OK()
'MJ le 22/01/2020
'On Error Resume Next
'Permet d'insérer une image dans une cellule
ChoixSauveImgs = "O" ' InputBox("voulez-vous copier les images dans le classeur (o/n)?"
Application.ScreenUpdating = False
'Lien et Nom du fichier
Fichier = "C:\Temp\Test.jpg"
'Fichier = "C:\Temp\Test2.jpg"
ActiveSheet.Pictures.Insert(Fichier).Select
'Coupe et place l'image dans la cellule en la redimensionnat à la taille de la cellule avec marge basse de 12
DoEvents
Application.ScreenUpdating = False
Rap = Selection.Width / Selection.Height
Selection.Cut
MargeBasse = 12
'https://docs.microsoft.com/fr-fr/office/vba/api/excel.shapes.addpicture
If Rap > 1 Then Set Shp = ActiveSheet.Shapes.AddPicture(Fichier, msoTrue, msoCTrue, ActiveCell.Left + 2, ActiveCell.Top + 2, Int((ActiveCell.Width - MargeBasse)), (ActiveCell.Width - MargeBasse) / Rap).Select
If Rap <= 1 Then Set Shp = ActiveSheet.Shapes.AddPicture(Fichier, msoTrue, msoCTrue, ActiveCell.Left + 2, ActiveCell.Top + 2, Int((ActiveCell.Height - MargeBasse) * Rap), (ActiveCell.Height - MargeBasse)).Select
Selection.Placement = xlMoveAndSize
'Choix pour sauver l'image en dur dans le fichier (O) ou en lien (N)
If ChoixSauveImgs = "N" Or ChoixSauveImgs = "n" Then Application.CutCopyMode = False: Exit Sub
'Format image GIF JPG PNG ou métafichier amélioré à changer dans "Image (GIF)"
If ChoixSauveImgs = "O" Or ChoixSauveImgs = "o" Then Selection.Cut: ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False, DisplayAsIcon _
:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub