Sub Ins_All_Images_PT()
Timer1 = Timer
Dim img As Picture, cel As Range
Application.ScreenUpdating = False
With ActiveSheet 'Sheets(1)
For Each cel In .Range("C2", Cells(Rows.Count, "C").End(xlUp))
If Not IsEmpty(cel) Then
Set img = .Pictures.Insert(cel.Offset(0, -1) & "\" & cel.Value)
'place_l_image_dans cel.Offset(, 1), img, 4
place_l_image_dans cel.Offset(0, 0), img, 4
End If
Next
End With
Application.ScreenUpdating = True
MsgBox Timer - Timer1
End Sub
'sub de placement et centrage de l'image dans la range en parametre tout en respectant son ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
Dim ratio#, W#, H#
With Shp
.ShapeRange.LockAspectRatio = msoTrue ' lock leratio indéformable
' calcul ratio
ratio = .Width / .Height 'ratio shape ou picture
W = Rng.Width ' width range
H = Rng.Height ' height range
If (W / H < ratio) Then 'comparaison ratio range/image
.Width = W - space 'en redimentionant le width le height se redimentionne automatiquement
Else 'ou
.Height = H - (space / ratio) 'en redimentionant le height le width se redimentionne automatiquement
End If
.Left = Rng.Left + ((Rng.Width - .Width) / 2) 'adaptation du left en fonction de la dimention width du shape
.Top = Rng.Top + ((Rng.Height - .Height) / 2) 'adaptation du top en fonction de la dimention height du shape
.Placement = 1
End With
End Sub