Affiche photo selon lien

Bonjour,

je fais appel à votre aide, j'ai cherché mais pas trouvé comment faire.

Je souhaite que la photo (lien en B31) s'affiche en C17 [PHOTOSHAPE]
Si aucun lien présent en B31, rien ne s'affiche, des qu'un lien apparait, la photo correspondante s'affiche en conservant son ratio hauteur x largeur et en respectant les limites de l'espace [PHOTOSHAPE]

merci de votre aide

fichier en pièce jointe

Quelqu'un aurait une solution, une piste, un point de départ ?

Bonjour,

Est-ce qu'il s'agit d'un lien unique ou sera-t-il amené à varier ? Et est-ce que le lien est obtenu par formule ou par saisie ?

Voici un essai avec un lien unique obtenu par saisie et une image nommée "nomimage" rendue visible/invisible selon les cas :

private sub worksheet_change(byval target as range)
set r = intersect(target, range("B31"))
if not r is nothing then
    if r.value = "C:\photo.jpg" then '<<<< ADAPTER VALEUR B31
        shapes("nomimage").visible = true '<<<< ADAPTER NOM IMAGE APRES L'AVOIR NOMMEE
    else
        shapes("nomimage").visible = false '<<<< IDEM
    end if
end if
end sub

Cdlt,

Bonjour,

J'aurais fait quelque chose comme cela, j'ai pas réussi à le mettre du premier coup à l'emplacement voulu, pour cela que je l'import, copie/colle et supprime en deux temps.

private sub worksheet_change(byval target as range)
    set r = intersect(target, ThisWorkbook.Worksheets("Feuil1").Range("B31"))
    If not r is nothing then
        If not IsEmpty(r) then
            With ThisWorkbook.Worksheets("Feuil1").Pictures.Insert(r.value)
                ' l'option conservé les proportions décoché
                .ShapeRange.LockAspectRatio = msoFalse
                ' définition de la taille hauteur / Largeur
                .ShapeRange.Height 141.73
                .ShapeRange.Width 141.73
                .Copy
                ThisWorkbook.Worksheets("Feuil1").Range("C17").Paste
                .Delete
            End With
        End If
    End If
End Sub

Bonjour à tous,

@Tenders, à partir de ton code, tu peux essayer ceci :

Sub copierImg()
    With ThisWorkbook.Worksheets("Feuil1").Pictures.Insert(ThisWorkbook.Worksheets("Feuil1").Range("B31"))
        ' l'option conservé les proportions décoché
        .ShapeRange.LockAspectRatio = msoFalse
        ' définition de la taille hauteur / Largeur
        .ShapeRange.Height 141.73
        .ShapeRange.Width 141.73
        .left = range("C17").left
        .top = range("C17").top
    End With
End Sub

Pour info, cette ligne de code vient de faire planter mon Excel 3 fois de suite.

    With ThisWorkbook.Worksheets("Feuil1").Pictures.Insert(ThisWorkbook.Worksheets("Feuil1").Range("B31"))

Salut tout le monde,

Est-ce que vous êtes sûrs de la méthode .pictures.insert ? L'autre fois, un membre rencontrait des problèmes avec la propriété .pictures qui, apparemment, ne reste disponible que pour des raisons de compatibilité.

Parce que sinon, il y a la méthode équivalente .addpicture https://docs.microsoft.com/fr-fr/office/vba/api/excel.shapes.addpicture

Mais j'avais la flemme de démarrer aussi fort !

Ah mais carrément j'avais pas cherché plus que cela je t'avoue mais avec l'évènement changement du worksheet, et les vérification nécessaire pour dire si oui ou non dans la cellule c'est un lien et qu'il y a un image au bout de ce chemin tu utilises cela ! j'ai fait un léger test et chez moi ça marche :

    Path = ThisWorkbook.Worksheets("Feuil1").Range("B31").Value
    dest = ThisWorkbook.Worksheets("Feuil1").Range("C17")
    'Vérification ...
    ThisWorkbook.Worksheets("Feuil1").Shapes.AddPicture Path, True, True, dest.Left, dest.Top, 70, 70

à modifier les 70, 70 avec la taille que tu veux

Bordel, incroyable !

Sub test()
With ThisWorkbook.Worksheets("Feuil1").Shapes
    .AddPicture Range("B31").Value, False, True, Range("C17").Left, Range("C17").Top, 241.5, 180.75
End With
End Sub

ou :

Sub test()
Feuil1.Shapes.AddPicture Range("B31").Value, False, True, Range("C17").Left, Range("C17").Top, 241.5, 180.75
End Sub

Quelle classe ce vocabulaire JoyeuxNoel, j'adore !

Non mais là grâce à vous, je découvre des trucs super, et qui vont m'être utiles à coup sûr. Je ne peux pas tout contrôler niveau vocabulaire !

Il faut que ça sorte de temps en temps p****n !

Super ! En plus, elle semble plus complète que la méthode insert...

Et je crois même que faire référence à la feuille n'est pas nécessaire vu que la macro sera exécutée lors d'un évènement sur la feuille ! Ca te fait gagner 7 caractères sur ta ligne de code^^

Tu m'as titillé, je viens de tester et il n'aime pas. Faut faire référence à la feuille quand même.
Mais oui, cette méthode est super complète. On fait un peu ce qu'on veut avec. Génial !

Tiens cadeau je me suis amusé petite fonction pour vérifier qu'il y a bien un file au bout de ton chemin :

Private Function Verif(path As String) As Boolean
    Dim FLD As Scripting.Folder
    Dim fil As Scripting.File
    Dim Fso As Scripting.FileSystemObject, nmfold As String, nmfile As String
    Verif = False
    On Error GoTo fin
    'récupérer le dossier parent
    nmfold = Left(path, Len(path) - InStr(StrReverse(path), "\"))
    nmfile = Right(path, InStr(StrReverse(path), "\") - 1)
    'tu peux ajouter les extensions que tu acceptes ...
    If nmfile like "*.png" then
        Set Fso = New Scripting.FileSystemObject
        Set FLD = Fso.GetFolder(nmfold)
        For Each fil In FLD.Files
            If fil.name = nmfile Then
                Verif = True
                Exit Function
            End If
        Next fil
    End If
    Exit Function
fin:
    'si par exemple il y a pas de dossier avec ce nom de dossier, si pas accès ...
    Verif = False
End Function

Alors là Mtek, ça c'est de la relance bien placée en tout cas !

Ah mince ! J'aurais essayé... Je pensais qu'avec l'évènement, ça irait.

@tenders : Tu sais qu'avec la fonction dir, tu peux le vérifier directement :

function fileexists(chemin$) as boolean
fileexists = dir(chemin) <> ""
end function

'ensuite dans le code
if not fileexists(range("B31").value) then exit sub

Oufff, mille merci pour toute vos réponses, je vais tester tout ça ce weekend.

C'est vraiment très apprécié!

@JOYEUXNOEL j'aime bien le code que tu me proposes... ça fonctionne comme je le souhaitais :-)

Je tente une modification mais, je n'y arrive pas.... j'ai l'impression de tourné autour !!!
Voici ce que je tente de faire (d'ajouter à ton code)

Si il n'y a rien dans la cellule B31, n'affiche rien, sinon affiche la photo du lien
Il ne manque que la partie... si il n'y a rien dans B31... n'affiche rien

Un genre de
if Cells("B31").value = "" then exit sub

Sub test()
With ThisWorkbook.Worksheets("Feuil1").Shapes
    .AddPicture Range("B31").Value, False, True, Range("C17").Left, Range("C17").Top, 241.5, 180.75
End With
End Sub

Bonjour,

Bien sûr !

Sub test()
If range("b31") ="" then exit sub
'ou cells(31,2)
' ou [B31] 
With ThisWorkbook.Worksheets("Feuil1").Shapes
     .AddPicture Range("B31").Value, False, True, Range("C17").Left, Range("C17").Top, 241.5, 180.75
End With
End Sub

Tu mélangeais un peu les 2 façons de dire. Tu y étais effectivement presque !

Bonjour à tous,

Voici une proposition en mixant ma première idée, le code de JoyeuxNoel et le test d'existence de Tenders_vba :

'MODULE DE LA FEUILLE CONCERNEE
private sub worksheet_change(byval target as range)
set r = intersect(target, range("B31"))
if not r is nothing then
    if r.value <> "" then '<<<< ADAPTER VALEUR B31
        shapes(r.value).visible = false
    else
        on error resume next
        shapes(r.value).visible = true
        if err.number = 9 then on error goto 0: call AjoutImage(r.value)
    end if
end if
end sub

'MODULE NORMAL
Sub AjoutImage(chemin$)
if dir(chemin) = "" then msgbox "Image introuvable", vbcritical: exit sub
With ThisWorkbook.Worksheets("Feuil1").Shapes
    .AddPicture(chemin, False, True, Range("C17").Left, Range("C17").Top, 241.5, 180.75).name = chemin
End With
End Sub

On rend l'image visible ou invisible, sauf lorsqu'elle n'existe pas (dans ce cas, on l'ajoute).

Je n'ai pas testé...

Cdlt,