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) :(
 

Pièces jointes

  • Test-Catalog-20160922.zip
    243.9 KB · Affichages: 90

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
 

Pièces jointes

  • test-20160928.zip
    279.6 KB · Affichages: 85

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?
 

Discussions similaires

Réponses
4
Affichages
491

Statistiques des forums

Discussions
311 720
Messages
2 081 907
Membres
101 836
dernier inscrit
karmon