VBA macro - Afficher des photos avec hauteur & largeur fixe

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

Bonjour,

Avec des OLEObject type "Image" et définir sa propriété "PictureSizeMode" :

Sub ChargeTrombinoscope()

    Dim Obj As OLEObject
    Dim Img As MSForms.Image
    Dim Fe As Worksheet
    Dim largeur As Single
    Dim Hauteur As Single
    Dim HautI As Single
    Dim GaucheI As Single

    Dim Chemin As String, Fichier As String
    Dim Nom, Prénom As String
    Dim splitArr() As String
    Dim Ligne As Integer

    Set Fe = Worksheets("Pix")

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

        'insère un objet "Image"
        Set Obj = Fe.OLEObjects.Add(ClassType:="Forms.Image.1", _
                                    Link:=False, _
                                    DisplayAsIcon:=False, _
                                    Left:=GaucheI, _
                                    Top:=HautI, _
                                    Width:=largeur, _
                                    Height:=Hauteur)

        'récupère l'objet dans la variable afin d'utiliser les propriétés qui lui sont propres
        Set Img = Obj.Object

        Img.Picture = LoadPicture(Chemin & Fichier)
        Img.PictureSizeMode = fmPictureSizeModeStretch

        'Fichier suivant
        Fichier = Dir()
        Ligne = Ligne + 1

    Loop

End Sub

C'est pas tres rapide et ça gèle, surtout avec 1400 photos! Ton code fonctionne, mais il n'est pas tres adapté pour mes besoins

J'utilise ce code ici-bas

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

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 de cette onglet est 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

En gros:

J'utilise un onglet Pix et un catalog. Dans l'onglet catalogue j'ai des cases avec des zone de recep et une cellule ou j'entre le numéro de photo (ou selectionne) et elle affiche dans la zone recep. Dans l'onglet Pix il y a tous les photos dans la colonne K, une par ligne et a gauche il y a le nom de la photo (qui est utilisé pour la recherche et l'affichage dans l'onglet catalog).

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?

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

J'ai joint le fichier