Inserer images cellule active.xlsx

Sub ImportImages()
   Dim oPict As New stdole.StdPicture
    ChDir "C:\Users\....\Pictures" 'adapter chemin dossier à ouvrir
  chemin = Application.GetOpenFilename
  If chemin = False Then Exit Sub 'annulation
  hauteur = 100 'a adapter la hauteur de l'image
 Set oPict = stdole.LoadPicture(chemin)
 ratio = oPict.Width / oPict.Height
If oPict.Height < oPict.Width Then 'mode paysage
largeur = hauteur * ratio
Else
largeur = hauteur * ratio
End If
     Columns(Colonne).ColumnWidth = largeur / 5.5
     Rows(Ligne & ":" & Ligne).RowHeight = hauteur
  ActiveSheet.Pictures.Insert(chemin).Select
  Var = Selection.Name
  Selection.ShapeRange.LockAspectRatio = msoFalse
  With ActiveSheet.Shapes(Var)
    .Top = Range(position).Top
    .Left = Range(position).Left
    .Height = hauteur
    .Width = largeur
     End With
     End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("A1:F38")) Is Nothing Then 'a adapter la plage de cellule
position = Target.Address
Ligne = Target.Row
Colonne = Target.Column
position = Replace(position, "$", "")
ImportImages
End If
End Sub