Microsoft 365 Afficher une image, présente dans l'ordinateur, à partir d'un chemin d'accès

[July35]

Bonjour,

Me revoilà avec un problème où je n'ai pas réussi à trouver de solution.

Dans ma base de donnée, j'ai une colonne qui correspond à un chemin d'accès à une photo enregistré sur mon ordinateur.
Je souhaiterai "tout simplement" qu'à partir d'un chemin d'accès, je puisse faire apparaître mes photos de façon que quand je génère mes fiches, les photos s'insèrent automatiquement.
Est'ce que ça existe en macro ?
J'ai essayé en ajoutant la ligne "ActiveSheet.Pictures.Insert [c11]" mais ça fait planter ma macro.

Je joint ma macro pour mieux illustrer ma demande.

Merci d'avance pour vos réponses !

 

[GALOUGALOU]

bonsoir july35, bonsoir le forum
sur le site de mr boisgontier vous devriez trouver la solution à votre problème

Les images et shapes

essayer d'adapter la macro ci-dessous

Sub essai()
  répertoirePhoto = "c:\mesdoc\" ' Adapter
  nom = "droc"
  ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg").Name = nom
  ActiveSheet.Shapes(nom).Left = [B2].Left
  ActiveSheet.Shapes(nom).Top = [B2].Top
End Sub

cordialement
galougalou

 

[July35]

Bonjour
Merci pour la réponse.
J'avais déjà étudiée la page de ce monsieur mais je n'ai pas réussie à trouver mon bonheur ... ou je n'ai pas compris ?
Dans mon cas j'ai déjà un chemin de renseigner "C:/mesdoc/XXX.jpg".
En adaptant votre proposition avec un chemin entier je n'ai pas réussie à le faire fonctionner, j'ai fait :
"
ActiveSheet.Pictures.Insert("C11").Name = Nom
ActiveSheet.Shapes(Nom).Left = [B2].Left
ActiveSheet.Shapes(Nom).Top = [B2].Top"

C11 c'est l'endroit où se trouve mon chemin entier vers mes photos.
Je ne comprends pas mon erreur ... je rappelle que je suis une grosse nulle en VB (ahah)

 

[GALOUGALOU]

re july35
nous allons faire simple avec le code ci-dessous

Sub ImportImage()
  Image = Application.GetOpenFilename("Fichiers Gif ou Jpg ,*.gif;*.jpg")
  If Image <> False Then
    a = Split(Image, "\")
    nomimage = a(UBound(a))
    Set c = ActiveCell
    With ActiveSheet
     .Pictures.Insert(Image).Name = nomimage
     .Shapes(nomimage).Height = c.Height
     .Shapes(nomimage).Left = c.Left + (c.Width - .Shapes(nomimage).Width) / 2
     .Shapes(nomimage).Top = c.Top
     .Shapes(nomimage).LockAspectRatio = msoTrue
   End With
End If
End Sub

un bouton de macro dans la feuille permettra de lancer la procédure et ouvrira l'explorateur. vous choisissez la photo et hop, elle est présente dans la feuille à la position du curseur

précision sur l' origine de la macro et du classeur, site de mr Boisgontier
cordialement
galougalou

 

[July35]

Désolé mais ce n'est pas ce que je souhaite faire.
Je ne sais pas si vous avez vu la macro que j'ai jointe à mon premier message ? A partir d'une base de donnée et une colonne représentant le chemin par photo je souhaite qu'en générant mes fiches, chaque fiche aient ces photos intégrés automatiquement grâce au chemin afficher sur la bonne case (c11).

 

[GALOUGALOU]

Re ok
Je regarde ca tranquillement ce soir avev un ordi
Cordialement

 

[GALOUGALOU]

bonsoir july35
et oui en regardant tranquillement je me rend bien compte que je ne répondais pas à votre problématique.
je ne suis pas totalement raccord avec votre demande, mais la solution que j'ai trouvé sur un autre forum est à explorer, car elle fonctionne très bien et elle est facilement adaptable.
l'impératif, c'est que le classeur soit dans le même dossier que celui contenant les photos et que toutes les photos soient dans le même dossier. (vous pouvez ouvrir votre classeur avec un raccourci sur le bureau ou dans le dossier de votre choix)

le code, adapter la colonne d'adresse ici B, la colonne d'affichage ici C, le nom du dossier ici PHOTOS, la feuille ici Feuil1

Sub Affiche_Image()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String                   ' Contiendra le nom de l'image
Dim Lg As Long                        ' Numéro de la dernière ligne colonne B

  Set Ws = Sheets("Feuil1")                                           ' Nom de la feuille

  Application.ScreenUpdating = False                                  ' Interdit le raffraîchissement d'écran

  Efface_Images

  With Ws

    For Lg = 1 To .Range("B65536").End(xlUp).Row                      ' Parcourt de toute la colonne B

      Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser
  
      On Error Resume Next                                            ' On s'affranchit des erreurs
      With .Pictures.Insert(Image).ShapeRange                         ' On insère l'image dont le nom est en colonne B
        .LockAspectRatio = msoFalse                                   ' On peut la redimmensionner comme on veut
        .Left = Ws.Cells(Lg, "C").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "C").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "C").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "C").Height                            ' hauteur
      End With
      If Err.Number > 0 Then                                          ' Si une erreur (image non présente)
        MsgBox .Cells(Lg, "B") & vbCr & "Image inexistante"           ' On le signale
      End If
    Next Lg
  End With
End Sub

le code d'effacement, adapter la colonne ici 3

Sub Efface_Images()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Sh As Shape                       ' Sert à manipuler les formes (images) déjà affichées

  Set Ws = Sheets("Feuil1")                                           ' Nom de la feuille

  With Ws

    For Each Sh In .Shapes                                            ' Parcourt de toute la collection formes (images)
      If Not Intersect(.Columns(3), Sh.TopLeftCell) Is Nothing Then   ' si elle est dans la colonne 3
        Sh.Delete                                                     ' On l'efface
      End If
    Next Sh
  End With

End Sub

le classeur ci-dessous comporte dans le dossier des photos exemples. avec un bouton macro toutes les photos listées dans la colonne B s'affiche.
je vous laisse découvrir.
cordialement
galougalou

 

[GALOUGALOU]

re july35 bonjour le forum
j'ai trouvé pour adapter le code ci dessus à votre problématique.
pour cibler un répertoire différent du dossier source, et donc dissocier classeur dossier
modifier la ligne de code ci-dessous

   Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser

par

  Image = "D:\Images\XTRAIN\" & .Cells(Lg, "B")

D:\Images\XTRAIN\ devant être remplacé par le chemin de votre dossier

B devant etre remplacé par votre colonne qui ne doit contenir que le nom de la photo (toutes les photos étant dans le même dossier)

cordialement
galougalou

 

[GALOUGALOU]

re
pour cibler les photos dans différents dossier remplacer le code ci-dessous

[CODE]   Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser

[/CODE]
par

    Image = .Cells(Lg, "B")

B devant être remplacé par votre colonne qui doit contenir l'adresse, le nom de la photo ,l’extension.
cordialement
galougalou

 

[GALOUGALOU]

re july35
le principe du #9 adapté à votre classeur
deux boutons (colonne AB et colonne AE pour afficher ou supprimer les photos, attention aucun bouton dans la colonne AD sous risque de suppression car toute les photos ou les boutons de macro sont effacés pendant la procédure
j'ai testé chez moi, totalement fonctionnel, à condition que la cible soit bien renseignée avec l'extension du fichier
cordialement
galougalou

 

[July35]

Bonjour Galougalou,
Merci beaucoup pour vos réponses mais ce n'est pas encore exactement ce que je recherche mais on s'y rapproche !
Ce n'est pas dans la base de donnée que je souhaite faire apparaître mes photos mais bien dans mes fiches générées automatiquement. Dans le fichier joint exemple, les fiches sont déjà générés : elles sont nommées "EU..." couleur verte.
Dans chacunes des fiches, il y a les cases fusionnées C11/D23 et C25/D38 qui doivent avoir les photos et non le lien.
Je n'arrive pas à faire adapter votre macro à ma demande, pourriez-vous m'aider s'il vous plait ?

 

[GALOUGALOU]

bonjour july35 bonjour le forum
autre problématique autre solution (cellule fusionnée) (puis j'ai trouvé d'autre solution plus simple depuis le dernier fil)

je vous propose d’insérer dans chaque feuille un événement à l'activation. (pour être raccord avec votre demande)
- de modifier le principe de fonctionnement des fils précédents, permettant une simplification.

visiblement vous avez un seul dossier photo (excellente solution) mettre l'adresse du dossier dans la macro

dans votre feuille base_donnée, nommé les photos avec le nom et l'extension et supprimer le chemin. JPEG_20200617130636224.jpg

Sub EffaceMentShapeChamp()
On Error Resume Next
  For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$c$11")) Is Nothing Then s.Delete
  Next s
    For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$c$25")) Is Nothing Then s.Delete
  Next s
End Sub
Sub insert1()
On Error Resume Next
répertoirePhoto = "E:\SA2E\AFFAIRES\MANCHE\VIRE\Technique\Phase_1\Fiches_Regards\Photos\" ' Adapter
Nom = Range("c11").Text
Set c = Range("c11").MergeArea
With ActiveSheet
Range("C11").Select
.Pictures.insert(répertoirePhoto & Nom).Name = Nom
.Shapes(Nom).Left = c.Left
.Shapes(Nom).Top = c.Top
.Shapes(Nom).LockAspectRatio = msoFalse
.Shapes(Nom).Height = c.Height
.Shapes(Nom).Width = c.Width
End With
End Sub

Sub insert2()
On Error Resume Next
répertoirePhoto = "E:\SA2E\AFFAIRES\MANCHE\VIRE\Technique\Phase_1\Fiches_Regards\Photos\" ' Adapter
Nom = Range("c25").Text
Set c = Range("c25").MergeArea
With ActiveSheet
Range("C25").Select
.Pictures.insert(répertoirePhoto & Nom).Name = Nom
.Shapes(Nom).Left = c.Left
.Shapes(Nom).Top = c.Top
.Shapes(Nom).LockAspectRatio = msoFalse
.Shapes(Nom).Height = c.Height
.Shapes(Nom).Width = c.Width
End With
End Sub

le classeur sera fonctionnel après vos modifications dans la feuille base_donnée. les photos seront visibles dans chaque fiche
cordialement
galougalou

 

[July35]

Bonjour Galougalou !

Merci beaucoup pour votre réponse ! Ca fonctionne très bien super !