JBOBO
XLDnaute Accro
Bonjour à tous,
J'ai recuperer sur ce forum, une macro permettant d'inserer des images dans des cellules (Un grand merci à M. BOISGONTIER pour cette macro plus que geniale).
J'ai malgré tout une requete :
Si je souhaite appliquer cette fonction sur une cellule fusionnée, l'image est de la taille de la hauteur de la 1ère ligne de la cellule fusionnée.
Y a t'il un moyen pour que cette image s'affiche à la dimension de la hauteur totale de la cellule fusionnée.
En espérant avoir été assez clair., sinon je peux essayer d'éclaircir.
Je vous joint la macro pour une meilleur comprehension.
Merci d'avance
J'ai recuperer sur ce forum, une macro permettant d'inserer des images dans des cellules (Un grand merci à M. BOISGONTIER pour cette macro plus que geniale).
J'ai malgré tout une requete :
Si je souhaite appliquer cette fonction sur une cellule fusionnée, l'image est de la taille de la hauteur de la 1ère ligne de la cellule fusionnée.
Y a t'il un moyen pour que cette image s'affiche à la dimension de la hauteur totale de la cellule fusionnée.
En espérant avoir été assez clair., sinon je peux essayer d'éclaircir.
Je vous joint la macro pour une meilleur comprehension.
Code:
Function AfficheImage(NomImage, Rep)
Application.Volatile
Set adr = Application.Caller
temp = NomImage & "_" & adr.Address
Existe = False
For Each s In adr.Worksheet.Shapes
If s.Name = temp Then Existe = True
Next s
If Not Existe Then
For Each k In adr.Worksheet.Shapes
p = InStr(k.Name, "_")
If Mid(k.Name, p + 1) = adr.Address Then k.Delete
Next k
If Dir(Rep & NomImage) = "" Then
AfficheImage = "Inconnu"
Else
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Rep)
Set myFile = myFolder.Items.Item(NomImage)
Taille = myFolder.GetDetailsOf(myFile, 26)
H = Val(Split(Taille, "x")(1))
L = Val(Split(Taille, "x")(0))
Ech = adr.Height / H
H = H * Ech
L = L * Ech
Set s = adr.Worksheet.Shapes.AddPicture(Rep & NomImage, True, True, adr.Left + 1, adr.Top + 1, L - 2, H - 2)
s.Name = NomImage & "_" & adr.Address
AfficheImage = "ok"
End If
End If
End FunctionMerci d'avance