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 Function

Il y a quelques paramètres dans la macro

Const deltaX = 10 ' horizontal
Const deltaY = 20 ' vertical
Const offsetX = 0
Const offsetY = 0

permettant 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é

Application ...

capture d ecran 586
54afficheimage.xlsm (206.61 Ko)

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 Function

La 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 Function

avec 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 image

si 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 Function

A 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, merci, sans doute plus pérenne que de passer par un objet IE

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

Rechercher des sujets similaires à "afficher photo valeur"