Sub InserImages()
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
xRowIndex = Application.ActiveCell.Row
For lLoop = LBound(PicList) To UBound(PicList)
Set Rng = Cells(xRowIndex, xColIndex)
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
'Selection.ShapeRange.LockAspectRatio = msoTrue
xRowIndex = xRowIndex + 1
place_l_image_dans Rng, sShape
Next
End If
End Sub
Sub SuppImg()
ActiveSheet.Pictures.Delete
End Sub
'patricktoulon
'version 2021 en agissant directement sur l'image
Sub place_l_image_dans(Rng As Range, Shp As Picture)
Dim x&
With Shp
.ShapeRange.LockAspectRatio = msoTrue ' met l'aspect Ratio a true
x = (Rng.Width / Rng.Height) < (.Width / .Height) 'comparaison des ratios
'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
If x Then .Width = Rng.Width Else .Height = Rng.Height
.Left = Rng.Left + ((Rng.Width - .Width) / 2)'débloquer si l'image doit etre au centre horizontalement
.Top = Rng.Top + ((Rng.Height - .Height) / 2)'débloquer si l'image doit etre au centre verticalement
.Placement = 1
End With
End Sub