Cette fonction personnalisée met en place des images dans des commentaires et non dans des cellules.
Elle est utilisable à l'intérieur même des Formules de vos feuilles.
Option Explicit
Function Cmt_Img(ByVal img_nom As Variant, Optional chemin As String = "") As String
Dim c As Range
If chemin = "" Then chemin = ActiveWorkbook.Path
If Right(chemin, 1) <> "\" Then chemin = chemin & "\"
Set c = Range(Application.Caller.Address) ' affecte à c la cellule de la formule
On Error Resume Next ' traite l'erreur d'absence de commentaire
c.Comment.Delete ' destruction du commentaire
On Error GoTo 0
Cmt_Img = "" ' initialisation de la valeur de retour
If img_nom > "" Then ' je controle si j'ai quelque chose à mettre
c.AddComment ' insertion d'un commentaire
c.Comment.Shape.Fill.UserPicture chemin & img_nom ' j'applique l'image
c.Comment.Visible = True ' Je la rend visible
c.Comment.Text " " ' je réinitialise le texte
Cmt_Img = "Img" & c.Address ' j'affecte un nom pour resultat
End If
End Function
=Cmt_Img(Image; [Path])
Image : Nom du fichier image à appliquer
Path : Chemin du fichier (Optionnel), s'il est omis prend le chemin du
classeur par défaut.
Voici une petite fonction personalisée qui permet d'afficher des images du disque dans une cellule.
Elle s'adapte à la taille de la cellule ou de la plage si c'est une plage fusionnée.
Elle s'utilise comme une formule Excel
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
