XL 2019 Afficher une photo stocker dans mon ordinateur et la générer à un endroit précis

[androsO]

Bonjour la communauté
Je me trouve dans une impasse.
Je souhaiterai dès lors que l'on clique sur une ligne dans le tableau de donnée, la photo extraite du lien présent en colonne D se génère dans mon tableau de bord à l'endroit où il est écrit Photo du véhicule.

Mes photos se trouve dans un dossier sur mon ordinateur

J'ai trouvé ça qui je pense est un début mais je ne suis pas sur

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" And Target.Count = 1 Then
On Error Resume Next
Shapes("Peugeot_206").Delete
RépertoirePhoto = "C:\Users\LENOVO\Desktop\vehicule\" ' adapter
nf = RépertoirePhoto & "\" & Target & ".jpg"
If Dir(nf) <> "" Then
Set img = ActiveSheet.Pictures.Insert(nf)
img.Name = "MonImage"
img.Left = [A5].Left
img.Top = [B5].Top
End If
End If
End Sub

Merci à tous

 

[Dudu2]

Bonjour,
J'ai pas regardé ton fichier, j'ai dans mon historique une fonction qui insère une image mais en passant par une shape rectangle. Si ça peut t'aider...

Sub InsererImage()
    Dim NomCompletImage As String
    Dim Sh As Shape
    Dim Left As Integer
    Dim Top As Integer
    Dim Width As Integer
    Dim Height As Integer
    
    Left = ActiveCell.Left
    Top = ActiveCell.Top
    Width = 10
    Height = ActiveCell.Height
 
    Set Sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left, Top, Width, Height) 'left, top, width, heigth
 
    NomCompletImage = "H:\Téléchargements\2020-06-18_142553.jpg"
    Sh.Fill.UserPicture NomCompletImage
End Sub

 

[androsO]

Tout d'abord merci pour ton retour Dudu2,
J'ai trouvé une autre discussion sur ce forum traitant du même sujet seulement une erreur revient.
aurais tu une solution pour contourner cela

 

[Dudu2]

Bonjour,
Mets un répertoire correct (avec les \ à la fin) et un nom correct et ça marchera.

'répertoirePhoto = "XXXXXX" ' Adapter
répertoirePhoto = "H:\Téléchargements\"
'Nom = Range("c11").Text
Nom = "20200704_160359.jpg"

 

[Dudu2]

Voici un code un peu plus organisé basé sur ce que tu m'as envoyé.
Remplacer Selection par le Range dans lequel tu veux insérer l'image ActiveSheet.Range("C5") ou ActiveSheet.Range("C5:E10").

Sub PlacerPhoto()
    Call EffacePhoto(Selection)
    Call InsertPhoto("H:\Téléchargements", "20200704_160359.jpg", Selection, RespecterProportions:=True)
End Sub

Sub EffacePhoto(ByVal Rng As Range)
    Dim s As Shape

    On Error Resume Next
    For Each s In ActiveSheet.Shapes
        If Not Intersect(s.TopLeftCell, Rng.Areas(1)) Is Nothing Then s.Delete
    Next s
    On Error GoTo 0
End Sub

Sub InsertPhoto(ByVal Répertoire As String, ByVal Image As String, ByVal Rng As Range, _
                Optional ByVal RespecterProportions As Boolean = False)
   
    Dim ShapeName As String
  
    'Ajout du \ au nom du répertoire
    If Right(Répertoire, 1) <> "\" Then Répertoire = Répertoire & "\"
    
    'Pour différencier le Shape Name et permettre d'avoir la même image plusieurs fois dans la feuille
    ShapeName = Rng.Areas(1).Address & Image
   
    'https://docs.microsoft.com/fr-fr/office/vba/api/excel.shaperange
    With ActiveSheet
        Rng.Areas(1).Select
        .Pictures.Insert(Répertoire & Image).Name = ShapeName
        .Shapes(ShapeName).Left = Rng.Areas(1).Left
        .Shapes(ShapeName).Top = Rng.Areas(1).Top
        .Shapes(ShapeName).Height = Rng.Areas(1).Height
        .Shapes(ShapeName).Width = Rng.Areas(1).Width
       
        If RespecterProportions Then
            .Shapes(ShapeName).LockAspectRatio = msoTrue
             If .Shapes(ShapeName).Height > Rng.Areas(1).Height Then
                .Shapes(ShapeName).Width = Rng.Areas(1).Width * (Rng.Areas(1).Height / .Shapes(ShapeName).Height)
            End If
        Else
            .Shapes(ShapeName).LockAspectRatio = msoFalse
        End If
       
    End With
End Sub