Images intelligentes dans Excel

ActiveSheet.Pictures.Insert(fich).Select

ActiveSheet.Shapes.AddPicture(fich, False, True, ActiveCell.Left, ActiveCell.Top, largeur, hauteur).Select

Sub AffImage()
    ' Sélectionner les cellules contenant un lien vers une image et appeler la macro
    ' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
    Const hDefaut = 75 ' hauteur des images
    Const imgDefaut = "Q:\Parts\Catalog\Photos\not_available.jpg" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
    Dim msg As String, r As Long, h As Long, lmax As Long
    Dim c As Range, numfich As Integer
    Dim fich
    msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
    msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
    msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
    r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
    If r = vbYes Then
        r = -1
    ElseIf r = vbNo Then
        r = 0
    Else
        r = 1
    End If
    h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
    For Each c In Selection
        'c.ColumnWidth = 20
        fich = c.Value
        ' test fichier
        If fich <> "" Then
            numfich = FreeFile()
            On Error GoTo errfich
            Open fich For Input As #numfich
            Close #numfich
        End If
            '
        If fich <> "" Then
            c.RowHeight = h 'fixer la hauteur de ligne
            
'À partir d'ici le code demande une révision.. mais fonctionne tout de meme
            
            ActiveSheet.Shapes.AddPicture(fich, False, True, ActiveCell.Left, ActiveCell.Top, largeur, hauteur).Select 'ouverture image
            With Selection.ShapeRange
                .LockAspectRatio = True 'conserver les proportions
                .Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
                .Left = c.Offset(0, h).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
                .Top = c.Top + 2 'et positionner verticalement
                If .Width > lmax Then lmax = .Width
                ' limitation largeur colonne
                If lmax > 500 Then lmax = 500
                c.Offset(0, h).ColumnWidth = lmax + 4
            End With
        End If
    Next c
    Exit Sub
errfich:
    fich = imgDefaut
    Resume Next
End Sub

Function AjusterImage(Imag As Object, Rapport As Single) 
Dim Largeur As Single 
Dim Hauteur As Single 

Largeur = Imag.Width 
Hauteur = Imag.Height 
Largeur = Largeur * Rapport 
Hauteur = Hauteur * Rapport 
Imag.Width = Largeur 
Imag.Height = Hauteur 
End Function

Dim h As Long, Rapport As Single 
Const hDefaut = 75 
h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut) 
h = h - 4 
With Selection.ShapeRange 
    Rapport = h / Selection.Height 
    AjusterImage Selection, Rapport 
End With

Sub AffImage() 
    ' Sélectionner les cellules contenant un lien vers une image et appeler la macro 
    ' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite 
    Const hDefaut = 75 ' hauteur des images 
    Const imgDefaut = "Q:\Parts\Catalog\Photos\not_available.jpg" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur 
    Dim msg As String, r As Long, h As Long, lmax As Long, Rapport As Single 
    Dim c As Range, numfich As Integer 
    Dim fich 

'bla bla bla ICI TON DEBUT DE CODE

With Selection.ShapeRange 
    Rapport = h / .Height 
    AjusterImage Selection, Rapport 
    .Left = c.Offset(0, h).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne) 
    .Top = c.Top + 2 'et positionner verticalement 
    If .Width > lmax Then lmax = .Width 
    ' limitation largeur colonne 
    If lmax > 500 Then lmax = 500 
    c.Offset(0, h).ColumnWidth = lmax + 4 
 End With 

' bla bla bla ICI LA FIN DE TON CODE