Afficher une photo selon une valeur
Bonjour,
Il arrive parfois qu'il faille ajouter une photo à une feuille de calcul, afin de compléter un devis, choisir un composant sans risque de se tromper, voire ajouter un QRCode.
Ci-après une fonction qui donnera une image dont le nom sera issu de la cellule appelante :
Option Explicit
Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0
Function MonImage( _
ByVal url As String, _
Optional ByVal largeur As Long = 130, _
Optional ByVal hauteur As Long = 150, _
Optional ByVal texte As String = "") As Variant
Dim oImg As Shape, oRng As Range
Set oRng = Application.Caller.Offset(offsetY, offsetX)
On Error Resume Next
Set oImg = oRng.Parent.Shapes(Application.Caller.Address)
oImg.Delete
On Error GoTo 0
If url = "" Then GoTo fin
On Error GoTo fin
Set oImg = oRng.Parent.Shapes.AddPicture(url, True, True, oRng.Left + deltaX, oRng.Top + deltaY, largeur, hauteur)
oImg.Name = Application.Caller.Address
MonImage = texte
Exit Function
fin:
MonImage = "pas d'image"
End FunctionIl y a quelques paramètres dans la macro
Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0permettant de régler la position de l'image
- dans une cellule voisine (offsetX et offsetY) si besoin
- par rapport au coin supérieur gauche de la cellule (deltaX et deltaY)
L'appel se fait via une fonction :
MonImage( url de l'image ; largeur optionnelle ; hauteur optionnelle ; texte optionnel à afficher )edit : retrait de l'exemple qui comportait des images non libres de droits, désolé
Bonjour, J'ai pu implémenter le code fourni votre exemple et suggéré par LouReed. C'est OK mais je dois afficher des images de taille différente. Ce sont des images de timbres-poste en format jpg. Or, largeur et hauteur sont en constante dans la macro. Je voudrais pouvoir aller chercher les caractéristiques de l'image avant et ainsi calculer un ratio correct afin que l'image ne soit pas déformée.
Si quelqu'un peut m'aider, ce serait super! merci d'avance
Option Explicit
Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0
Function MonImage( _
ByVal url As String, _
ByVal repertoire As String, _
ByVal fichier As String, _
Optional ByVal largeur As Long = 600, _
Optional ByVal hauteur As Long = 150, _
Optional ByVal texte As String = "") As Variant
Application.Volatile
Dim oImg As Shape, oRng As Range, oLargImage As Integer, oHautImage As Integer
Dim iPict As IPictureDisp
oLargImage = 513 / 2
oHautImage = 600 / 2
Set oRng = Application.Caller.Offset(offsetY, offsetX)
On Error Resume Next
Set oImg = oRng.Parent.Shapes(Application.Caller.Address)
oImg.Delete
On Error GoTo 0
If url = "" Then GoTo fin
On Error GoTo fin
Set oImg = oRng.Parent.Shapes.AddPicture(url, msoFalse, msoTrue, oRng.Left + deltaX, oRng.Top + deltaY, largeur, hauteur)
oImg.Name = Application.Caller.Address
MonImage = texte
Exit Function
fin:
MonImage = "pas d'image"
End FunctionLa seule chose que j'ai trouvé pour obtenir la taille de l'image est de simuler son chargement dans IE
Option Explicit
Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0
Function MonImage( _
ByVal url As String, _
Optional ByVal texte As String = "") As Variant
Application.Volatile
' taille image
Dim sht As Worksheet
Dim IE As Object
Dim IEPage As Object
Dim IEPageImgElements As Object
Dim larg, haut
On Error Resume Next
Set IE = CreateObject("InternetExplorer.Application")
If Err.Number <> 0 Then
MsgBox "Sorry, it was impossible to start Internet Explorer!", vbCritical, "Internet Explorer Error"
Exit Function
End If
IE.Navigate url
Do Until IE.ReadyState = 4 'READYSTATE_COMPLETE in early binding
DoEvents
Loop
Set IEPage = IE.document
Set IEPageImgElements = IEPage.getElementsByTagName("img")
If IEPageImgElements.Length > 0 Then
With sht
larg = IEPageImgElements(0).Width
haut = IEPageImgElements(0).Height
End With
Set IEPageImgElements = Nothing
End If
IE.Quit
Set IEPage = Nothing
Set IE = Nothing
' fin taille image
Dim oImg As Shape, oRng As Range
Set oRng = Application.Caller.Offset(offsetY, offsetX)
On Error Resume Next
Set oImg = oRng.Parent.Shapes(Application.Caller.Address)
oImg.Delete
On Error GoTo 0
If url = "" Then GoTo fin
On Error GoTo fin
Set oImg = oRng.Parent.Shapes.AddPicture(url, True, True, oRng.Left + deltaX, oRng.Top + deltaY, larg, haut)
oImg.Name = Application.Caller.Address
MonImage = texte
Exit Function
fin:
MonImage = "pas d'image"
End Functionavec IE, pas sûr que ce soit pérenne
tu peux ensuite si besoin redimensionner en conservant le ratio haut/larg
pour trouver une autre solution, n'hésite pas à ouvrir un topic du style "comment récupérer haut et larg d'une image située sur le net en http://..............jpg"
Bonjour Steelson,
Je vous remercie pour votre réactivité !
Bonne continuation et voyons ce qu'en pense Jean-Pierre Mouligne (y a pas plus court en pseudo ?
@ bientôt
LouReeD
@mon_presque_jumeau LouReeD
je ne suis pas très satisfait de la solution trouvée pour récupérer les dimensions d'une image
' taille image
Dim sht As Worksheet
Dim IE As Object
Dim IEPage As Object
Dim IEPageImgElements As Object
Dim larg, haut
On Error Resume Next
Set IE = CreateObject("InternetExplorer.Application")
If Err.Number <> 0 Then
MsgBox "Sorry, it was impossible to start Internet Explorer!", vbCritical, "Internet Explorer Error"
Exit Function
End If
IE.Navigate url
Do Until IE.ReadyState = 4 'READYSTATE_COMPLETE in early binding
DoEvents
Loop
Set IEPage = IE.document
Set IEPageImgElements = IEPage.getElementsByTagName("img")
If IEPageImgElements.Length > 0 Then
With sht
larg = IEPageImgElements(0).Width
haut = IEPageImgElements(0).Height
End With
Set IEPageImgElements = Nothing
End If
IE.Quit
Set IEPage = Nothing
Set IE = Nothing
' fin taille imagesi tu as mieux, je sis preneur.
Bonsoir,
en reprenant une fonction que j'utilise dans Mosaïc Maker, voici ce que cela donne, reste à voir comment vous voulez intégrer les données "calculées" :
Option Explicit
Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0
Function MonImage( _
ByVal url As String, _
ByVal repertoire As String, _
ByVal fichier As String, _
Optional ByVal largeur As Long = 600, _
Optional ByVal hauteur As Long = 150, _
Optional ByVal texte As String = "") As Variant
Application.Volatile
Dim oImg As Shape, oRng As Range, oLargImage As Integer, oHautImage As Integer
Dim iPict As IPictureDisp
' ********************************************************************************
' début de modification LouReeD
Dim Taille_Img, X, Y, Temp, LeRatio
Taille_Img = DimensionsImage(url)
' si l'image ne représente rien
If Taille_Img = "" Then Exit Function
' on découpe les dimensions de l'image
' en partant du premier caractère on recherche "espace x espace" ce qui va nous donner l'emplacement du premier espace dans la chaine taille
Temp = InStr(1, Taille_Img, " x ")
' la taille de l'image en X est égale à la deuxième valeur de la chaine Taille_Img
' donc on extrait à partir de Temp + 3 (l'espace + le x + l'espace) et on retire 1 afin de ne pas avoir une ligne grise à droite et
' en bas sur la feuille résultat
X = Val(Mid(Taille_Img, Temp + 3, Len(Taille_Img))) - 1
' on fait pareille pour le Y
Y = Val(Left(Taille_Img, Temp - 1)) - 1
' fin de modification
'**********************************************************************************
oLargImage = 513 / 2
oHautImage = 600 / 2
Set oRng = Application.Caller.Offset(offsetY, offsetX)
On Error Resume Next
Set oImg = oRng.Parent.Shapes(Application.Caller.Address)
oImg.Delete
On Error GoTo 0
If url = "" Then GoTo fin
On Error GoTo fin
Set oImg = oRng.Parent.Shapes.AddPicture(url, msoFalse, msoTrue, oRng.Left + deltaX, oRng.Top + deltaY, largeur, hauteur)
oImg.Name = Application.Caller.Address
MonImage = texte
Exit Function
fin:
MonImage = "pas d'image"
End Function
Public Function DimensionsImage(fichier As String)
' par Excel-Malin.com ( https://excel-malin.com )
' merci @ eux !
' en cas d'erreur on va à l'étiquette Erreur et on attribue à la fonction une chaine vide
On Error GoTo Erreur
Dim DimensionsI, ImageDossier As Variant, ImageFichier As Variant
Dim objShell As Object, objDossier As Object, objFichier As Object
' on recherche le dernier "\" grâce à l'intrustion de recherche "inverse", c'est à dire on regarde à partir de la droite
' de la chaine de carractère, et on ajoute 1 pour le premier carractère du nom de l'image
' Exemple : mon_chemin\mesimages\LouReeD.jpg
' InStrRev renvoie 21 car le premier "\" en reverse (en partant de la droite) se trouve à 21 caractères à partir de la gauche
' +1 pour tomber sur le 22 => L, du coup Mid retourne le restant de fichier en partant du 22ième caractère soit LouReeD.jpg
ImageFichier = Mid(fichier, InStrRev(fichier, "\") + 1)
' on récupère l'adresse du fichier en enlevant le nom de l'image
ImageDossier = Left(fichier, Len(fichier) - Len(ImageFichier)) ' =>mon_chemin\mesimages\
' on crée un objet Shell afin de pouvoir travailler sur "les fichiers"
Set objShell = CreateObject("Shell.Application")
' on crée un objet "dossier" afin de cibler le dossier voulue grâce à son chemin
Set objDossier = objShell.Namespace(ImageDossier) ' mon_chemin\mesimages\
' on crée un objet fichier
Set objFichier = objDossier.ParseName(ImageFichier) ' LouReeD.jpg
' on met en mémoire en "texte" les propriétés de l'image
DimensionsI = CStr(objFichier.ExtendedProperty("Dimensions")) ' ?255 x 860?
DimensionsI = Left(DimensionsI, Len(DimensionsI) - 1) ' on racourcie d'un caractère par la droite => ?255 x 860
DimensionsImage = Right(DimensionsI, Len(DimensionsI) - 1) ' on racourcie d'un caractère par la gauche => 255 x 860
' on vide les objets de la mémoire
Set objFichier = Nothing
Set objDossier = Nothing
Set objShell = Nothing
' on sort de la fonction
Exit Function
Erreur:
DimensionsImage = ""
End FunctionA voir si cela fonctionne car à l'origine l'url est déterminée par la boite de dialogue de recherche de fichier, ici elle serait égale à une donnée dans votre feuille Excel, je pense que cela ne fait pas de différence, mais à voir...
@ bientôt
LouReeD
top,
Bonsoir,
Merci pour ces encouragements ! Je n'ai pas testé, mais la fonction "chipée" ailleurs fonctionne bien dans mon application, alors...
@ bientôt
LouReeD
Merci pour le coup de main. Pas d'erreur de syntaxe mais j'ai l'impression d'avoir loupé quelque chose. Pour moi le résultat est le même.
Je ne suis pas spécialiste VBA mais je ne vois pas où on charge la hauteur et la largeur de l'image avant de l'afficher. Ces argument sont fixes tel que je peux comprendre en lisant le code. (je peux me tromper)
Bonjour,
où vois-tu que la taille est fixe ? voici un extrait du code que j'avais proposé ...
La seule chose que j'ai trouvé pour obtenir la taille de l'image est de simuler son chargement dans IE
... Function MonImage( _ ByVal url As String, _ Optional ByVal texte As String = "") As Variant Application.Volatile ' taille image ... larg = IEPageImgElements(0).Width haut = IEPageImgElements(0).Height ... Set oImg = oRng.Parent.Shapes.AddPicture(url, True, True, oRng.Left + deltaX, oRng.Top + deltaY, larg, haut) ... End Function
Bonsoir,
et pour ce que j'ai proposé, une fois que vous avez le X et le Y, tien qu'à vous d'en faire ce que vous voulez : Largeur = Y/2, Hauteur = X/2 et votre image est réduite de 3/4.
@ bientôt
LouReeD
Bonjour Steelson, Loureed,
J'aimerais savoir si çà peut fonctionner avec un publipostage, vu que les enregistrements sont dans une feuille de calcul.
Un exemple avec ce document issu d'un publipostage ou figure une capture d'écran par page faite manuellement.
Merci