Option Explicit
' Ecrite le 16/09/2008 par Wilfried_42
Function Image(img_nom As Variant, Optional chemin As String = "") As String
' Declaration des variables
Dim ref As Range, sh As Shape, drap As Boolean
' ref : la cellule qui provoque la fonction
' sh : les shapes
' Drap : drapeau definissant si la shape est trouvée
Application.Volatile ' defini une fonction qui se recalcule automatiquement
' teste le type de variable soit une cellule soit une valeur alphanumerique
Select Case TypeName(img_nom)
Case "Range" ' c'est une reference cellule
Image = img_nom.Value
Case "String" ' c'est une valeur alphanumerique
Image = img_nom
Case Else ' c'est une erreur
Image = "#ERROR"
Exit Function
End Select
' le chemin est un parametre optionnel, s'il est omis, la valeur est le chemin du classeur
If chemin = "" Then chemin = ThisWorkbook.Path
' le chemin ne se termine pas forcemment par \ je le rajoute
If Right(chemin, 1) <> "\" Then chemin = chemin & "\"
Set ref = Application.Caller ' affectaction à ref de la cellule qui lance la fonction
If ref.MergeCells = True Then Set ref = Range(ref.MergeArea.Address)
drap = False ' initialisation du drapeau
For Each sh In ref.Worksheet.Shapes ' je passe en revue toute les shapes
' je teste son nom construite plus bas pour savoir si c'est la bonne shappe
If "Img-" & ref.Address = Left(sh.Name, Len(ref.Address) + 4) Then drap = True: Exit For
Next
If drap = True Then ' c'est la bonne shape
' je teste maintenant si c'est la meme que celle de la formule pour ne pas refaire le traitement
' Le gain de temps n'est pas negligeable
If "Img-" & ref.Address & "-" & Image = sh.Name Then GoTo fin ' egalité parfaite, je sors
End If
On Error Resume Next ' controle d'erreur, si la shape n'existe pas encore, l'instruction suivante provoque une erreur
sh.Delete ' je detruits la shap
If Image = "" Then Exit Function ' la valeur est à "" alors pas de shape à affecter
' j'inserre la shape, avec l'image en lui mettant les tailles necessaires pour la cellule
Set sh = ref.Worksheet.Shapes.AddPicture(chemin & Image, True, True, ref.Left, ref.Top, ref.Width, ref.Height)
sh.Name = "Img-" & ref.Address & "-" & Image ' je definis son nom pour la trouver plus tard
fin:
Image = "Img" & ref.Address ' j'affecte un nom pour resultat
End Function
