Microsoft 365 VBA - Insertion image depuis un dossier extérieur, suivant une valeur d'une cellule à partir d'une liste déroulante.

Arthur EXL

XLDnaute Nouveau
Bonjour,

Après avoir consulté plusieurs forums et effectué quelques tests avec le peu de connaissances que j'ai en VBA, je me tourne vers vous

Mon Objectif : insérer une image depuis un dossier spécifique, dans une cellule spécifique, en fonction du texte dans une cellule.
Je m'explique : j'ai créer un fichier qui me permet de retrouver un équipement à partir du secteur dans lequel il se trouve (listes en cascade), le tout en VBA.

L'ordre de saisi est le suivant : Secteur > Equipement > Sous-Equipement
De plus, le code vient réécrire en dessous les sélections, ainsi que des informations en plus (pas encore présentes mais se sont les deux colonnes vides).
1622723736524.png

Je voudrais que si on sélectionne l'équipement "M21 Ventilateur" par exemple, ça me fasse apparaître l'image correspondante, dans une cellule spécifique, et que si par la suite on vient sélectionner une sous-équipement "Armoire Electrique" par exemple, ça remplace l'image du M21 Ventilateur par celle de l'armoire..

J'espère avoir été simple et claire dans mes explications, et que vous pourrez m'aider pour mon projet :)

Merci par avance de toute pistes ou réponses. Si besoin je peux partager le fichier pour une meilleure compréhension ...

Cordialement,

Arthur
 
Solution
Re bonjour,
Ca y est, de nouveau accès au site. Du coup, voici un nouveau code qui permet d'insérer une image et de l'agrandir/réduire au contenu H8:I22
Bien sur, le chemin et nom d'image sont à adapter à ton besoin
VB:
Sub Cmd_AfficheImage2_Cliquer()
    Application.ScreenUpdating = False
    On Error Resume Next
    xNomGénériqueImage = "MonImage"
    ActiveSheet.Shapes.Range(Array("" & xNomGénériqueImage & "")).Delete
    xRépertoireImage = "C:\Users\toto\Pictures\"             'A adapter
    xFichierImage = "fenetre2.jpg"                               'Nom d'image a afficher
    Nf = xRépertoireImage & "\" & xFichierImage
    If Dir(Nf) <> "" Then
        Set C = Range("H8").MergeArea
        With ActiveSheet...

Lolote83

XLDnaute Accro
Re bonjour,
Ca y est, de nouveau accès au site. Du coup, voici un nouveau code qui permet d'insérer une image et de l'agrandir/réduire au contenu H8:I22
Bien sur, le chemin et nom d'image sont à adapter à ton besoin
VB:
Sub Cmd_AfficheImage2_Cliquer()
    Application.ScreenUpdating = False
    On Error Resume Next
    xNomGénériqueImage = "MonImage"
    ActiveSheet.Shapes.Range(Array("" & xNomGénériqueImage & "")).Delete
    xRépertoireImage = "C:\Users\toto\Pictures\"             'A adapter
    xFichierImage = "fenetre2.jpg"                               'Nom d'image a afficher
    Nf = xRépertoireImage & "\" & xFichierImage
    If Dir(Nf) <> "" Then
        Set C = Range("H8").MergeArea
        With ActiveSheet
            .Pictures.Insert(xRépertoireImage & xFichierImage).Name = xNomGénériqueImage
            .Shapes(xNomGénériqueImage).Left = C.Left
            .Shapes(xNomGénériqueImage).Top = C.Top
            .Shapes(xNomGénériqueImage).LockAspectRatio = msoFalse
            .Shapes(xNomGénériqueImage).Height = C.Height
            .Shapes(xNomGénériqueImage).Width = C.Width
        End With
    End If
    Application.ScreenUpdating = True
End Sub
@+ Lolote83
 

Arthur EXL

XLDnaute Nouveau
Bonjour
Si le cadre contient un OLEObject Image, on devrait pouvoir l'affecter à sa propriété Picture
.Picture = LoadImage(CheminNomFic)
Remarque: pour mettre en CurDir un tel dossier, la séquence ChDrive/ChDir ne marche pas, il faut utiliser l'API SetCurrentDirectoryA
Merci du retour,
En revanche, mes connaissances en VBA sont limités, ce que tu me dis ne me parle pas du tout ... :s
 

Arthur EXL

XLDnaute Nouveau
Re bonjour,
Ca y est, de nouveau accès au site. Du coup, voici un nouveau code qui permet d'insérer une image et de l'agrandir/réduire au contenu H8:I22
Bien sur, le chemin et nom d'image sont à adapter à ton besoin
VB:
Sub Cmd_AfficheImage2_Cliquer()
    Application.ScreenUpdating = False
    On Error Resume Next
    xNomGénériqueImage = "MonImage"
    ActiveSheet.Shapes.Range(Array("" & xNomGénériqueImage & "")).Delete
    xRépertoireImage = "C:\Users\toto\Pictures\"             'A adapter
    xFichierImage = "fenetre2.jpg"                               'Nom d'image a afficher
    Nf = xRépertoireImage & "\" & xFichierImage
    If Dir(Nf) <> "" Then
        Set C = Range("H8").MergeArea
        With ActiveSheet
            .Pictures.Insert(xRépertoireImage & xFichierImage).Name = xNomGénériqueImage
            .Shapes(xNomGénériqueImage).Left = C.Left
            .Shapes(xNomGénériqueImage).Top = C.Top
            .Shapes(xNomGénériqueImage).LockAspectRatio = msoFalse
            .Shapes(xNomGénériqueImage).Height = C.Height
            .Shapes(xNomGénériqueImage).Width = C.Width
        End With
    End If
    Application.ScreenUpdating = True
End Sub
@+ Lolote83
Re bonjour,

J'étais en train de répondre à ton dernier poste quand j'ai vu celui-ci :)
Effectivement ton dernier code fonctionne, et j'ai trouvé le problème. Mon système Windows est en anglais (je travail dans une entreprise internationale) tandis que ce qui est affiché est en français ! Donc les liens doivent être mis en anglais. (Ex : C:\Users\xxx\Pictures et non C:\Users\xxx\Images).
Je vais tester ton nouveau code, en essayant de faire en sorte que les images apparaissent en fonction de ce qui est écrit dans la cellule J5 (suite à la sélection dans les listes) et non l'utilisation d'un bouton.

En attendant, je te remercie pour le coup de pouce !
Je te tiens au courant de mon avancée :)
 
Dernière édition:

Arthur EXL

XLDnaute Nouveau
VB:
Sub AfficheImage()
    Application.ScreenUpdating = False
    On Error Resume Next
    xNomGénériqueImage = "MonImage"
    ActiveSheet.Shapes.Range(Array("" & xNomGénériqueImage & "")).Delete
    xRépertoireImage = "LIEN"             'A adapter
    image = Range("J5").Value
    xFichierImage = "image.jpg"                               'Nom d'image a afficher
    Nf = xRépertoireImage & "\" & xFichierImage
    If Dir(Nf) <> "" Then
        Set C = Range("H8").MergeArea
        With ActiveSheet
            .Pictures.Insert(xRépertoireImage & xFichierImage).Name = xNomGénériqueImage
            .Shapes(xNomGénériqueImage).Left = C.Left
            .Shapes(xNomGénériqueImage).Top = C.Top
            .Shapes(xNomGénériqueImage).LockAspectRatio = msoFalse
            .Shapes(xNomGénériqueImage).Height = C.Height
            .Shapes(xNomGénériqueImage).Width = C.Width
        End With
    End If
    Application.ScreenUpdating = True
End Sub

J'ai essayé ce code en créant une variable image = Range("J5").Value pour récupérer la valeur en J5, et ainsi utiliser cette variable dans la ligne xFichierImage = "image.jpg".
Est-ce que c'est possible de faire ca ?
 

Dranreb

XLDnaute Barbatruc
Que ce soit pour une image ActiveX ou de formulaire, essayez plutôt :
VB:
xFichierImage = Dir(xRépertoireImage & "\" & Range("J5").Value & ".*")
(xRépertoireImage ayant été renseigné correctement, bien entendu, ou non précisé nulle part mais préalablement mis comme CurDir par un SetCurrentDirectoryA déjà évoqué plus haut)
 
Dernière édition:

Arthur EXL

XLDnaute Nouveau
Que ce soit pour une image ActiveX ou de formulaire, essayez plutôt :
VB:
xFichierImage = Dir(xRépertoireImage & "\" & Range("J5").Value & ".*")
(xRépertoireImage ayant été renseigné correctement, bien entendu, ou non précisé nulle part mais préalablement mis comme CurDir par un SetCurrentDirectoryA déjà évoqué plus haut)
Très bien le programme fonctionne ! 😁
Maintenant lorsque je sélectionne un sous-équipement, l'image associée apparaît là ou elle doit être.
En revanche, j'ai constaté que s'il n'y a pas d'image, ça met un message d'erreur. Il ne me reste plus que ce détail pour que ma problématique de départ soit résolue... Une idée ?
1622806531276.png
 

Dranreb

XLDnaute Barbatruc
VB:
ArgDir = xRépertoireImage & "\" & Range("J5").Value & ".*"
xFichierImage = Dir(ArgDir)
If xFicherImage = "" Then MsgBox "Il n'existe pas de fichier """ & ArgDir & """.", _
   vbCritical, LeNomDeLaProcédure): Exit Sub
 

Arthur EXL

XLDnaute Nouveau
VB:
ArgDir = xRépertoireImage & "\" & Range("J5").Value & ".*"
xFichierImage = Dir(ArgDir)
If xFicherImage = "" Then MsgBox "Il n'existe pas de fichier """ & ArgDir & """.", _
   vbCritical, LeNomDeLaProcédure): Exit Sub
Bonsoir,
Désolé pour la réponse très tardive, j'ai eu quelques problèmes perso...
Je voulais clôturer ce sujet car votre aide m'a permis d'atteindre mes objectifs...
Peut être que j'ouvrirai d'autres sujets si je suis bloqué sur une fonctionnalité que je souhaite ajouter à mon fichier.
Merci à @Dranreb et @Lolote83 pour votre temps et solutions ;)
 

Membres actuellement en ligne

Statistiques des forums

Discussions
288 693
Messages
1 894 017
Membres
170 246
dernier inscrit
Fahdj2002
Haut Bas