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

[John-87]

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

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]

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 :

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]

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

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

 

[jecherche]

Bonjour,

Sans fichier pour tester, je ne crois pas être en mesure de tout tester ce code.


Jecherche

 

[John-87]

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)

 

[John-87]

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

 

[jecherche]

Bonjour,

Bon je me reprends plus tard...

Jecherche

 

[John-87]

Est-ce qu'il y a un Guru qui aurait la solution ?

 

[jecherche]

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


Jecherche

 

[John-87]

c'est pas le bon fichier Il n'y a pas ta macro a l'intérieur.

Le bon fichier a un bouton pour load les photos et ta macro. (join ci-dessous)

 

[jecherche]

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.
L'important pour l'instant, c'est qu'il fonctionne.

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

Jecherche

 

[John-87]

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é.

 

[jecherche]

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]

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]

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!