XL 2010 VBA macro - Afficher des photos avec hauteur & largeur fixe\proportionnel

John-87

XLDnaute Nouveau
Bonjour,

Est-ce que quelqu'un serait en mesure de modifier le code ci-dessous pour que les photos affiches soient proportionnel a l'image original et quelle soit maximum la hauteur de 3,57cm et largeur de 6,03cm svp

Code:
Sub ChargeTrombinoscope()
    Dim Chemin As String, Fichier As String
    Dim Nom, Prénom As String
    Dim splitArr() As String
    Dim Ligne As Integer
    Worksheets("Pix").Activate

    'Définit le répertoire contenant les fichiers
    Chemin = "C:\test-20160928\MyPH\"
    'Boucle sur tous les fichiers du répertoire (photos).
    Ligne = 3
    Fichier = Dir(Chemin & "*")
    Do While Len(Fichier) > 0
        'Extraction prénom
         splitArr = Split(Fichier, ".")
         Prénom = splitArr(0)
         Range("H" & Ligne).Value = Prénom
         'insertion de la photo dans la colonne C
          Largeur = ActiveSheet.Cells(Ligne, 11).Width
        Hauteur = ActiveSheet.Cells(Ligne, 11).Height
        GaucheI = ActiveSheet.Cells(Ligne, 11).Left
        HautI = ActiveSheet.Cells(Ligne, 11).Top
        ActiveSheet.Shapes.AddPicture Chemin & Fichier, False, True, GaucheI, HautI, Largeur, Hauteur
        'Fichier suivant
        Fichier = Dir()
        Ligne = Ligne + 1
    Loop
End Sub
 

jecherche

XLDnaute Occasionnel
Bonjour,

Est-ce que quelqu'un serait en mesure de modifier le code ci-dessous pour que les photos affiches soient proportionnel a l'image original et quelle soit maximum la hauteur de 3,57cm et largeur de 6,03cm svp
Bonjour,
La largeur et hauteur des cellules se calculent en point ... 1 point = 0,035 cm
Une approche à tester :
Code:
Sub ChargeTrombinoscope()
Dim Chemin As String, Fichier As String
Dim Nom, Prénom As String
Dim splitArr() As String
Dim Ligne As Integer
  
Worksheets("Pix").Activate

  'Définit le répertoire contenant les fichiers
Chemin = "C:\test-20160928\MyPH\"
  
  'Boucle sur tous les fichiers du répertoire (photos).
Ligne = 3
Columns("K:K").ColumnWidth = 172  ' défini la largeur de la colonne

Fichier = Dir(Chemin & "*")
Do While Len(Fichier) > 0
  'Extraction prénom
  splitArr = Split(Fichier, ".")
  Prénom = splitArr(0)
  Range("H" & Ligne).Value = Prénom
  'insertion de la photo dans la colonne K
  Range("K" & Ligne).Select
  

  ActiveSheet.Pictures.Insert(Chemin & Fichier).Select
  ActiveCell.RowHeight = 100  ' ajuste la hauteur de la ligne : 1 point = 0,035 cm
  With Selection.ShapeRange
  .Left = ActiveCell.Left
  .Top = ActiveCell.Top
  .Height = 100  ' ajuster la hauteur : 1 point = 0,035 cm
'  .Width = 150  ' ou la largeur
  .LockAspectRatio = msoTrue  ' conserve le proportion de l'image
  End With
  Range("H3").Select
  
  'Fichier suivant
  Fichier = Dir()
  Ligne = Ligne + 1
Loop
End Sub

Jecherche
 

John-87

XLDnaute Nouveau
Merci!

Par contre, dans un autre onglet je selectionne le nom de l'image et elle apparait dans la zone recep. Lorsque je supprime le numéro de l'image la photo disparait. Maintenant avec ce code, la photo reste dans la zone recep et ce même si je supprime le numéro de l'image. Est-ce qu'il y a moyen de faire en sorte que lorsque je supprimer le numéro de produits l'image disparait de la zone recep, comme avant?

PTI le code ci-dessous

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ZoneRecep As Range
Dim Cel As Range
Dim Sh As Shape
Dim PosX As Double, PosY As Double

  If Target.Count > 1 Then Exit Sub
  If Target.Row Mod 7 <> 0 Then Exit Sub                  ' Lignes 7, 14, 21, 28 ....
  If InStr(1, "159", Trim(Str(ActiveCell.Column))) Then   ' Colonnes A E I
    Set ZoneRecep = Cells(Target.Row - 3, Target.Column)
    With Application
      .ScreenUpdating = False
      '.EnableEvents = False
    End With
  
    ' Recherche dans les images si une est présente dans la zone recep
    For Each Sh In ActiveSheet.Shapes
      If Sh.Type = msoPicture Then
        If Sh.TopLeftCell.Row = ZoneRecep.Row Then   ' Même ligne : 1er filtre
          If Sh.TopLeftCell.Column >= ZoneRecep.Column And Sh.TopLeftCell.Column < ZoneRecep.Offset(0, 1).Column Then
            Sh.Delete
            Exit For
          End If
        End If
      End If
    Next Sh
  
    If Target = "" Then Exit Sub    ' Aucun numéro on quitte
  
    ' C'est la macro qui fera la recherche
    Set Cel = Sheets("Pix").Columns("B").Find(what:=Target, LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
      Set Sh = Sheets("Pix").Shapes(Cel.Offset(0, 1))
      PosX = ZoneRecep.Left + ((ZoneRecep.Offset(0, 1).Left - ZoneRecep.Left) / 2) - Sh.Width / 2
      PosY = ZoneRecep.Top + ((ZoneRecep.Offset(1, 0).Top - ZoneRecep.Top) / 2) - Sh.Height / 2
      Sheets("Pix").Shapes(Cel.Offset(0, 1)).Copy
      ActiveSheet.Paste ZoneRecep
      With Selection                                      ' Pour 2007 et plus
      'With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)  ' Pour 2003
        .Top = PosY
        .Left = PosX
      End With
      Target.Select
    Else
      MsgBox "No corresponding picture"
    End If
  End If
End Sub
 

John-87

XLDnaute Nouveau
Voilà j'ai joint le fichier

il y a une macro dans l'onglet Catalog et une autre dans le module 1 pour l'onglet Pix.

1-Dans l'onglet Pix : Clique sur Load Pictures, il va afficher les photos du dossier dans le même onglet.
2-Aller dans L'onglet Catalog et entrer ou sélectionner dans les case verte un numéro de photo.
3- La photo affiche dans la zone de recep. Si on supprime le numéro de photo de la case verte avec la touche "supprimer" du clavier, la photo disparait de la zone recep.
(normalement ça le fesait, mais maintenant avec le nouveau code qui prend tous les photos d'un dossier et les importent ça ne fonctionne plus) :(
 

Fichiers joints

John-87

XLDnaute Nouveau
Est-ce qu'il y a moyen de faire en sorte que lorsque je supprimer le numéro de produits l'image disparaît de la zone recep?

Merci de votre aide, c'est très apprécié!

désolé, le fichier précèdent n'est pas bon!

Ne pas oublier, le dossier MyPH doit être dans C:\test-20160928\MyPH\ (ou modifier au besoin dans le code)

J'ai joint le fichier
 

Fichiers joints

jecherche

XLDnaute Occasionnel
Bonjour,

J'avais opté pour cette approche. Puis, tout s'est mis à aller de travers; en choisissant une image, ou en la supprimant, on perdait les listes déroulantes.
Aujourd'hui, je teste à nouveau et ça semble fonctionner.
Je suis perplexe.
Donc, à tester et sûrement à améliorer :D


Jecherche
 
Dernière édition:

jecherche

XLDnaute Occasionnel
Bonjour,

Je ne sais pas comment est mon Gu, s'il est Ru; mais, ça fonctionne. ;)
Ne pas oublier que dans la macro d'import images le dossier est présentement :
Chemin = "C:\test-20160928\MyPH\" ... à adapter ...
Lors de l'ajout d'images, les images du même nom, s'empilaient l'une par-dessus l'autre. Ce qui aurait pu devenir très lourd.
J'ai corrigé en supprimant les images avant de les importer à nouveau.
J'ai effectué quelques autres petites modifications dans le Module1.
J'ai aussi trouvé le bogue de l'effacement des images dans la feuille "Catalog".
If Sh.Type = msoLinkedPicture Then ' et non 'msoPicture Then
Perso, je n'aime pas les menus déroulants dans la feuille "Catalog"; ils ouvrent toujours une ligne plus bas que le dernier item. Mais, aime/n'aime pas ... ce n'est pas mon fichier. :p
L'important pour l'instant, c'est qu'il fonctionne.

À tester bien sûr... :D
(meilleur fichier aux posts suivants)

Jecherche
 
Dernière édition:

John-87

XLDnaute Nouveau
Merci!

#1 - les photos ne restent pas dans le fichier. Par Exemple si j'envoi le fichier a quelqu'un, le lien de l'image ne fonctionne plus et il y a une affiche d'erreur.

Les photos affichent, Sub CheckImageName() N'était pas activé.
 
Dernière édition:

jecherche

XLDnaute Occasionnel
Bonjour,

Sur ma machine, ça fonctionne correctement sous Excel 2016.
Les images et leur nom sont bien lus dans le dossier en cliquant sur le bouton.
Dans l'onglet Catalog, je peux, via un menu déroulant, sélectionner une image.
Puis, si je retourne effacer le nom, l'image est bien supprimée.
J'ai testé en sélectionnant plusieurs images dans des cases différentes avant de tenter de les supprimer.
On peut aussi, après avoir sélectionner une image, retourner en sélectionner une autre au cas d'une erreur.
Demain, je vais démarrer une autre machine et y installer Excel 2010 le temps de tester.
Je suis bien malheureux, je croyais avoir réussi. M'enfin ...

À demain alors ...


Jecherche
 

John-87

XLDnaute Nouveau
Les photos affiche, désolé. Dans la macro tu avais enlever le Sub CheckImageName()

Le fichier que tu m'as envoyer contient pas de photos, il y a des affiche d'erreur liens images.

Est-ce qu'il y a possibilité que les photos reste dans le fichier et ce même si je n'envoie que seulement le fichier Excel a quelqu’un qui n'as pas les photos?
 

John-87

XLDnaute Nouveau
J'ai mis des images avec nom: 14004 , 5000, C-1053

Les image 14004 et 5000 return une erreur runtime Set Sh = Sheets("Pix").Shapes(Cel.Offset(0, 1))

Mais les images C-1053... alphanumérique avec un - , fonctionne! Je comprend pas!
 

John-87

XLDnaute Nouveau
Bon, j'ai découvert. Les photos doivent se nommer avec un trait d'union et quelque-chose ensuite. EX: XXX-X, 12345-6

Pourquoi? Aucune possibilité d'avoir avec ou sans trait d'union? EX: XXXX, 123456

Il est compliqué ce fichier !!
 

jecherche

XLDnaute Occasionnel
Bonjour,

Pour les noms des photos, probablement que la recherche ou un variable utilise que le texte et, en numérique, ça bogue; je regarde cela.
Mais avant, j'ai besoin de comprendre le fonctionnement de la feuille "Pix". Pourquoi les colonnes BC versus JI ?
Les menus déroulants de la feuille "Catalog" utilise un champ-nommé "PicTable" lequel faire référence aux colonnes BC (à partir de la ligne 3) de la feuille "Pic".
Tandis que, la macro qui importe les images dépose les noms dans la colonne H de cette même feuille.
Tout ça c'est bien confus pour moi.


Jecherche
 

John-87

XLDnaute Nouveau
Bonjour,

Pour répondre à ta question:

Avant j'ajoutais les photos moi même (une a une) et je devais créer un nom pour chaque photos dans le "Name Box".

Les colonnes H et I servais a ma mise a jour et ensuite je copiais les colonne et je collais dans B et C.

Dans G et J il y a une formule qui me disais si le même nom ou la même image était présente en double. C'était une vérif avant que je colle dans les colonnes B et C.

Maintenant que le procédé est automatisé (enfin presque) je n'ai plus besoin de faire tout le travail manuellement. J'ai plus de 1400 photos... C'est très long faire les mises à jour manuellement!

Je préfère garder ce fonctionnement au cas ou j'ai des modifications manuelle a faire.

Merci énormément de ton aide!
 

jecherche

XLDnaute Occasionnel
Bonjour,

Donc, si j'ai bien compris, on pourrait n'utiliser que les colonnes BC.
Un autre point, incorporer 1400 images, le fichier va devenir très lourd.
Que penses-tu de l'idée que les photos soient dans le dossier et que l'on charge directement les seules photos nécessaires au fur et à mesure des besoins ? En fait, la feuille Pix aurait la liste, mais lors du choix sur la feuille Catalog, au lieu de lire l'image sur la feuille Pix, elle serait lue directement du dossier sur le disque.
En attendant ta réponse, je vais regarder pour les faire toutes se charger dans la feuille Pix.

Je te reviens demain, car ici, c'est proche de ma mise en veille, avant ma mise en veille prolongée. ;)


Jecherche
 

jecherche

XLDnaute Occasionnel
Bonjour,

On m'a brassé la souris, du coup, je suis sorti de la mise en veille prolongée. :p
Voici la dernière version sur laquelle j'ai travaillé ce matin.
Les images s'installent bien sur la feuille "Pix" et le code n'utilise plus que la colonne H.
En sélectionnant la feuille Catalog, menu Formules, Gestionnaire des noms, j'ai automatisé l'adressage de "PicTable" qui est maintenant dynamique, avec le premier item vide (bout de code à la toute fin de la macro d'importation des images). "PicTable" sert au menu dérolant de choix des cellules à fond vert du la feuille "Catalog".
Si les images avaient un nom numérique, comme tu me l'as souligné, ça ne fonctionnait pas.
Je ne suis pas sûr, mais je crois que cela provient qu'un shape doit avoir un nom texte.
En cogitant sur ce point, j'ai pensé à tout simplement ajouter le caractère de soulignement "_" devant le nom de l'image ... en espérant que cela ne pose pas problème ailleurs.


À tester ...


Jecherche
 

Fichiers joints

Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas