Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
répertoire = ThisWorkbook.Path
lig = [liste].Find(Target, LookAt:=xlWhole).Row
col = [liste].Column + 1
Sheets("dessins").Cells(lig, col).CopyPicture
x = Sheets("dessins").Cells(lig, col).Width
y = Sheets("dessins").Cells(lig, col).Height
ActiveSheet.Paste Destination:=Range("A1") 'crée un shape
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Copy
With ActiveSheet
.ChartObjects.Add(0, 0, s.Width, s.Height * 1.15).Chart.Paste
.ChartObjects(1).Border.LineStyle = 0
.ChartObjects(1).Chart.Export Filename:=répertoire & "\monimage.gif", FilterName:="gif"
.Shapes(ActiveSheet.Shapes.Count).Delete
.Shapes(ActiveSheet.Shapes.Count).Delete
End With
On Error Resume Next
Target.Comment.Delete
Target.AddComment
Target.Comment.Shape.Fill.UserPicture répertoire & "\monimage.gif"
Target.Comment.Shape.Height = y
Target.Comment.Shape.Width = x
End If
End Sub