Discussion :

[SixteenVBA]

Bonjour à tous !

Je me posais une question à propos de la faisabilité d'insérer des images en jpeg dans une feuille excel suivant une variable contenue dans une liste déroulante.
Enfait, je réalise des documents sur excel, avec notamment des recherchev qui vont chercher toutes les infos d'une référence produit et qui remplisse donc le document directement. J'aimerai dans la même lancée, pouvoir ajouter les photos (format jpeg) du produit lorsque celui ci est choisi dan sla liste déroulante et que donc l'image soit directement importée d'un dossier où sont stockées toutes les images nommées de la référence produit. A noter, qu'il peut y avoir plusieurs images par référence et que par conséquent lorsque c'est le cas, les images sont nommées ainsi : xxxx-1.jpeg, xxxx-2.jpeg, etc.
Le code vba dirait donc d'insérer les images CONTENANT la variable dans leur nom.

Avez-vous déjà réalisé ceci? Est-ce possible? Pouvez-vous m'aider?

Merci à vous.

[Invité]

Bonjour,

Peut-être une solution ici tri-automatique-photos

Cordialement.

[SixteenVBA]

Merci de votre réponse. J'ai voulu télécharger le fichier xls que vous proposiez mais ça ne fonctionne pas... Le lien envoi sur une page qui reste blanche... POuvez-vous le mettre ici?

Merci

[Invité]

Bonjour,

J'ai effectivement un problème avec mes fichiers .xlsm. Je suis obligé de les ziper.

Pièce jointe 220720

Il vous faut également charger les photos associées. La liste déroulante est dans l'onglet Maquette.

Cordialement.

[SixteenVBA]

Je reviens vers vous car je n'arrive pas à adapter les macros...
J'ai modifié ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub MettreAJourLesImages()
 
' La référence Microsoft Windows Image Acquisition Library doit être cochée.
 
 
      Set Sh = Sheets("Logistic sheet - Template")
      Set CelluleImport = Sh.Range("A68")
      Set CelluleRepertoirePhoto = Sh.Range("M2")
      Set CelluleNomPrenom = Sh.Range("C63:E63") 'car cellules fusionnées"

Et il me semblait de rien avoir d'autre à modifier... Je me trompe? Je vois aussi que ca m'affiche "Photo non trouvée" dans la CelluleImport, et si je vais sur celle-ci ainsi que toutes celles nommées dans la macro ne cessent de "clignoter" ... Pouvez-vous m'aider?
Mes photos sont enregistrées comme dans votre fichier d'origine : référence-1.jpeg, référence-2.jpeg etc.

[Invité]

Dans l'onglet Base de données, il vous faut modifier le chemin d'accès au répertoire contenant les photos, en cliquant sur le bouton Répertoire Photos

Pièce jointe 220749

Dans le fichier exemple, la base de données contient 3 noms : Immeuble1, 2,3.

Le fichier de photos contient les photos dont les noms contiennent Immeuble1, 2, 3 dans leur racine

Pièce jointe 220752

Dans l'onglet Maquette, le changement dans liste déroulante lance la macro récupérant les images.

Pièce jointe 220750

Essayez d'utiliser l'outil sans modifier le code pour l'instant. Il vous suffit de définir le répertoire des photos.

Cordialement.

[SixteenVBA]

Merci pour votre rapidité. J'ai testé l'outil plusieurs fois en effet avant d'essayer de l'adapter dans mon classeur Excel. Je pensais pouvoir copier les macros en ne modifiant que la partie que je vous ai précédemment cité, mais ça ne fonctionne pas avec tous les désagréments que je vous ai également énoncé, et aussi la fermeture inopinée d'Excel.
Dans mon fichier, j'ai mis l'adresse du répertoire photo dans la même feuille que la liste déroulante.

[Invité]

L'outil a-t-il fonctionné correctement sans modifications (hormis le chemin du répertoire photos) avec les photos jointes ?

La référence Windows Image Acquisition est-elle cochée ?

Pièce jointe 220762

Sinon :

Comment avez-vous modifié le code de la macro "MettreAJourLesImages" ?


Cordialement.

[SixteenVBA]

Oui votre fichier a fonctionné en modifiant seulement le répertoire d'images.
C'est quand je l'adapte à mon propre fichier que cela ne fonctionne pas.
Comment je dois faire pour vérifier que c'est coché? J'utilise Excel 2007...

[Invité]

Comment je dois faire pour vérifier que c'est coché? J'utilise Excel 2007...

Dans l'éditeur VBA, menu Outils Références


Pouvez-vous mettre votre code en ligne ?

Cordialement.

[SixteenVBA]

Merci.
J'ai vérifié et ça n'était pas coché... Pourtant votre fichier de base fonctionne bien. Bref, je l'ai coché.
Voici mon code pour la macro "MettreAJourLesImages":

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub MettreAJourLesImages()
 
' La référence Microsoft Windows Image Acquisition Library doit être cochée.
 
 
      Set Sh = Sheets("Logistic sheet - Template") 
      Set CelluleImport = Sh.Range("A68")   'Cellule où va s'importer l'image
      Set CelluleRepertoirePhoto = Sh.Range("M2") 'Cellule où se trouve l'adresse du répertoire
      Set CelluleNomPrenom = Sh.Range("C63")  'Cellule où se trouve la liste déroulante 
 
      LargeurImagePaysage = 319
      LargeurImagePortrait = 212
 
      If CelluleRepertoirePhoto = "" Or VerificationExistenceRepertoire(CelluleRepertoirePhoto) = False Then
              FichierAOuvrir = Application.GetOpenFilename("Fichiers(*.jpg;*.gif;*.bmp),*.jpg;*.gif;*.bmp")
              If FichierAOuvrir <> False Then CelluleRepertoirePhoto = CurDir
      End If
 
      If VerificationExistenceRepertoire(CelluleRepertoirePhoto) = True Then
              PhotoTrouvee = False
 
              RecupererLesImages Sh, CelluleImport, CelluleRepertoirePhoto
              If PhotoTrouvee = False Then CelluleImport = "Photo non trouvée"
      End If
 
 
      Set CelluleNomPrenom = Nothing
      Set CelluleRepertoirePhoto = Nothing
      Set CelluleImport = Nothing
      Set Sh = Nothing
 
End Sub

[Invité]

Quand vous lancez directement la macro MettreAJourLesImages, que se passe-t-il ?

Dans mon fichier, la macro MettreAJourLesImages est lancée par l'événement WorkSheet_Change sur changement de valeur de la cellule (liste déroulante) (module de l'onglet Maquette). Dans votre fichier, comment lancez-vous la macro ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Private Sub WorkSheet_Change(ByVal CelluleCible As Range)
 
   If CelluleCible.Count > 1 Then Exit Sub
 
   On Error Resume Next
   If Not Application.Intersect(CelluleCible, Range("NomPrenom")) Is Nothing Then MettreAJourLesImages
 
End Sub

Cordialement.

[SixteenVBA]

Il semblerait que depuis que j'ai coché la case tout fonctionne... Merci à vous!

En revanche une question, pourquoi votre fichier marchait-il sans que je sois allée la cocher?

Je vais encore abuser de votre aide... Dans quelle partie du code se trouve la facon d'insérer les images? En effet vous les insérer les unes à coté des autres, et moi je souhaite le faire les unes en dessous des autres... Si votre aide me permettait d'éviter de faire des bêtises...

[Invité]

En revanche une question, pourquoi votre fichier marchait-il sans que je sois allée la cocher?

Sans expliquer pourquoi, je pense que la référence de la DLL est quand même contenue dans le fichier, sinon le code ne fonctionnerait pas. En revanche, si le code fait référence à des objets contenus dans la DLL sans l'avoir déclarée au moins une fois, c'est certain que ça plante.

Je vais encore abuser de votre aide... Dans quelle partie du code se trouve la facon d'insérer les images? En effet vous les insérer les unes à coté des autres, et moi je souhaite le faire les unes en dessous des autres

La macro ci-dessous met les images en vertical :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
 
 
Sub RecupererLesImagesEnVertical(ByVal FeuilleEnCours As Worksheet, ByVal CelluleImage As Range, ByVal Repertoire As String)
 
Dim MonImage As Shape
Dim MonFichier As String
Dim NbImages As Integer
Dim PositionGauche As Double
Dim PositionHaut As Double
 
    FeuilleEnCours.Activate
    For Each MonImage In FeuilleEnCours.Shapes
        Select Case Mid(MonImage.Name, 1, Len("ImageFeuille"))
               Case "ImageFeuille"
                    Application.DisplayAlerts = False
                    MonImage.Delete
                    Application.DisplayAlerts = True
        End Select
    Next MonImage
 
    On Error Resume Next
    ChDir Repertoire
 
    PositionGauche = CelluleImage.Left
    PositionHaut = CelluleImage.Top
 
    NbImages = 1
    MonFichier = Dir(Repertoire & "\*.*")
    Do While MonFichier <> ""   ' Commence la boucle.
       Select Case Mid(MonFichier, 1, Len(CelluleNomPrenom))
              Case CelluleNomPrenom
                    RecupererLesInformationsSurLImage Repertoire & "\" & MonFichier
                    PhotoTrouvee = True
                    Select Case FormatImage
                           Case "Paysage"
                                ActiveSheet.Shapes.AddShape(msoShapeRectangle, PositionGauche, PositionHaut, HauteurImagePaysage, HauteurImagePaysage / RatioImage).Select
                                Selection.Name = "ImageFeuille" & NbImages
                                With Selection.ShapeRange.Fill
                                     .Visible = msoTrue
                                     .UserPicture Repertoire & "\" & MonFichier
                                     .TextureTile = msoFalse
                                     .ForeColor.ObjectThemeColor = msoThemeColorText1
                                End With
                                With Selection.ShapeRange.Line
                                     .Visible = msoTrue
                                     .Weight = 1
                                End With
                                PositionHaut = PositionHaut + (HauteurImagePaysage / RatioImage) + 10
 
                           Case "Portrait"
                                ActiveSheet.Shapes.AddShape(msoShapeRectangle, PositionGauche, PositionHaut, HauteurImagePortrait, HauteurImagePortrait / RatioImage).Select
                                Selection.Name = "ImageFeuille" & NbImages
                                With Selection.ShapeRange.Fill
                                     .Visible = msoTrue
                                     .UserPicture Repertoire & "\" & MonFichier
                                     .TextureTile = msoFalse
                                     .ForeColor.ObjectThemeColor = msoThemeColorText1
                                End With
                                With Selection.ShapeRange.Line
                                    .Visible = msoTrue
                                    .Weight = 1
                                End With
                                PositionHaut = PositionHaut + (HauteurImagePortrait / RatioImage) + 10
 
                           End Select
 
                       NbImages = NbImages + 1
 
        End Select
        MonFichier = Dir   ' Extrait l'entrée suivante.
   Loop
 
End Sub

Par ailleurs, il faut déclarer deux variables en haut du module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
 
Public HauteurImagePortrait As Single
Public HauteurImagePaysage As Single

Changer les valeurs par défaut des images dans MettreAJourLesImages

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
 
Sub MettreAJourLesImages()
 
' La référence Microsoft Windows Image Acquisition Library doit être cochée.
 
 
      Set Sh = Sheets("Maquette")
      Set CelluleImport = Sh.Range("C5")
      Set CelluleRepertoirePhoto = Sheets("Base de données").Range("RepertoirePhotos")
      Set CelluleNomPrenom = Sh.Range("NomPrenom")
 
      LargeurImagePaysage = 319
      LargeurImagePortrait = 212
 
      HauteurImagePaysage = 212
      HauteurImagePortrait = 319
 
      If CelluleRepertoirePhoto = "" Or VerificationExistenceRepertoire(CelluleRepertoirePhoto) = False Then
              FichierAOuvrir = Application.GetOpenFilename("Fichiers(*.jpg;*.gif;*.bmp),*.jpg;*.gif;*.bmp")
              If FichierAOuvrir <> False Then CelluleRepertoirePhoto = CurDir
      End If
 
      If VerificationExistenceRepertoire(CelluleRepertoirePhoto) = True Then
              PhotoTrouvee = False
              CelluleImport = ""
              RecupererLesImagesEnVertical Sh, CelluleImport, CelluleRepertoirePhoto
             ' RecupererLesImages Sh, CelluleImport, CelluleRepertoirePhoto
              If PhotoTrouvee = False Then CelluleImport = "Photo non trouvée"
      End If
      CelluleNomPrenom.Activate
 
      Set CelluleNomPrenom = Nothing
      Set CelluleRepertoirePhoto = Nothing
      Set CelluleImport = Nothing
      Set Sh = Nothing
 
End Sub

Nb : J'ai modifié le pas d'incrémentation des images dans

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
PositionHaut = PositionHaut + (HauteurImagePaysage / RatioImage) + 10
'et
PositionHaut = PositionHaut + (HauteurImagePortrait / RatioImage) + 10

Cordialement.

[Invité]

J'ai mis à jour la visionneuse en tenant compte des modifications vues plus haut.

La modification du 20/09/2016 permet d'aligner les photos verticalement ou horizontalement. Les préférences sont déterminées dans un nouvel onglet "Paramètres".

Pièce jointe 220777
Pièce jointe 220778

Mon blog est également à jour : chargement-automatique-photos

[SixteenVBA]

Merci énormément pour tout ! Tout fonctionne. Merci d'avoir pris du temps pour m'aider et aide les prochains grâce à ce post

[JPSonic]

Bonjour Eric KERGRESSE
Bonjour à tous !

Après une petite recherche sur le forum, je suis arrivé sur cet excellent post qui permet d'afficher des images d'un répertoire dans une feuille via une liste déroulante.

J'ai réussi à intégrer la proposition de M KERGRESSE sans trop de difficulté. il me reste a l'adapter à ma liste déroulante qui se trouve sur les feuilles "de recherche" nommées : Recherche_1, Recherche_2, Recherche_3.

Je souhaiterai avoir votre aide afin de pouvoir utiliser plusieurs feuilles de recherche (feuilles identiques sur la forme mais pas sur leur contenues).

J'utilise déjà un menu déroulant afin de faire apparaître des informations spécifiques.

En testant le fichier, j'ai pu observer que si l'on nomme les images 1.jpg....10.jpg.....50.jpg cela ne fonctionne pas, il faut du texte avant les chiffres.

serait-il possible de m'aider sur ce petit problème et sur le fait de pouvoir utiliser ce menu déroulant sur plusieurs feuilles (modification de la macro).

En vous remerciant par avance de votre aide.

JP

[Invité]

Bonjour,

Dans la colonne A de l'onglet "Base de données" ou de vos différents onglets équivalents, il faut que le nom des images soit typé alphanumérique.
Il vous faut donc mettre une apostrophe avant vos nombres. Ex : '1

[JPSonic]

Bonjour et merci à vous M KERGRESSE pour cette réponse, concernant le nom des images.

Je tente de modifier la macro VBA afin de pouvoir l'utiliser sur 3 feuilles spécifiques, sachant que je n'y connais rien en VBA.

J'y vais par petite touche en essayant de comprendre le code.

Pour le moment cela fonctionne pas vraiment, mais il y a une chose que je ne comprends pas : a chaque modification d'une liste déroulante d'une feuille, je passe à la feuille suivante mais l'image sélectionner est pourtant bien visible ??

j'ai ajouter dans le module1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Set Sh = Sheets("Maquette2")
      Set CelluleRepertoirePhoto = Sheets("Paramètres").Range("RepertoirePhotos")
      Set CelluleNomPrenom = Sh.Range("NomPrenom2")
 
      Set Sh = Sheets("Maquette3")
      Set CelluleRepertoirePhoto = Sheets("Paramètres").Range("RepertoirePhotos")
      Set CelluleNomPrenom = Sh.Range("NomPrenom3")

J'ai également modifier NomPrenom dans la macro des feuilles 2 et 3 en NomPrenom2, NomPrenom3

Vous me seriez d'une grande aide pour solutionner cette demande.

En vous remerciant par avance

[Invité]

Bonjour,

Je ne pige pas trop comment est organisé votre fichier (à vrai dire, je ne cherche pas trop). Mettez un fichier en ligne avec quelques images. Si problème de confidentialité, me l'envoyer en privé.