Sub PlacerPhoto()
Call EffacePhoto(Selection)
Call InsertPhoto("H:\Téléchargements", "20200704_160359.jpg", Selection, RespecterProportions:=True)
End Sub
Sub EffacePhoto(ByVal Rng As Range)
Dim s As Shape
On Error Resume Next
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Rng.Areas(1)) Is Nothing Then s.Delete
Next s
On Error GoTo 0
End Sub
Sub InsertPhoto(ByVal Répertoire As String, ByVal Image As String, ByVal Rng As Range, _
Optional ByVal RespecterProportions As Boolean = False)
Dim ShapeName As String
'Ajout du \ au nom du répertoire
If Right(Répertoire, 1) <> "\" Then Répertoire = Répertoire & "\"
'Pour différencier le Shape Name et permettre d'avoir la même image plusieurs fois dans la feuille
ShapeName = Rng.Areas(1).Address & Image
'https://docs.microsoft.com/fr-fr/office/vba/api/excel.shaperange
With ActiveSheet
Rng.Areas(1).Select
.Pictures.Insert(Répertoire & Image).Name = ShapeName
.Shapes(ShapeName).Left = Rng.Areas(1).Left
.Shapes(ShapeName).Top = Rng.Areas(1).Top
.Shapes(ShapeName).Height = Rng.Areas(1).Height
.Shapes(ShapeName).Width = Rng.Areas(1).Width
If RespecterProportions Then
.Shapes(ShapeName).LockAspectRatio = msoTrue
If .Shapes(ShapeName).Height > Rng.Areas(1).Height Then
.Shapes(ShapeName).Width = Rng.Areas(1).Width * (Rng.Areas(1).Height / .Shapes(ShapeName).Height)
End If
Else
.Shapes(ShapeName).LockAspectRatio = msoFalse
End If
End With
End Sub