Déformation d'images lors de leur importation

Bonjour tout le monde,

Je me permet de solliciter votre aide pour une question assez simple d'import de 600 images dans un tableau. Je précise que je suis débutant mais ça ne devrait vraiment pas être compliqué.

J'ai trouvé en ligne ce code qui permet d'importer plusieurs images et de les insérer chacune à la suite des autres dans une colonne.

Tout fonctionne très bien, le seul problème est que les images sont déformées pour remplir l'intégralité de la cellule.

J'aimerais qu'elles ne remplissent la cellule qu'au maximum de leur hauteur sans déformation de la largeur (elles n'ont pas toutes la même taille donc je ne peux pas résoudre le problème simplement en changeant la largeur de la colonne).

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

Merci d'avance pour votre aide !

Bonjour,

Je vous invite à lire l'aide sur la fonction que vous utilisez : Méthode Shapes.AddPicture (Excel) | Microsoft Learn

En changeant les arguments Width et Height par -1 et -1, vous devriez obtenir le résultat voulu.

Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)

Relisez votre code, vous verrez que vous donnez comme instruction d'insertion de l'image : largeur = largeur de la cellule ("Rng.Width") et hauteur également.

//

Une petite remarque : faites attention le classeur peut devenir très lourd avec beaucoup d'images.

Merci pour votre aide,

en effet je me doutais que le problème se situait de ce côté-là.

Avec votre solution l'image garde sa taille d'origine, qui est trop grande pour la cellule.

Il faudrait donner comme instruction de redimensionner à la hauteur de cellule ("Rng.Height" je suppose) tout en gardant la proportion hauteur/largeur originale.

Pouvez-vous m'indiquer quelle est l'instruction qui donne ce résultat ?

Les images ne sont pas lourdes et je vais les compresser pour ne pas surcharger le tableau.

Encore merci !

Pour redimensionner la cellule effectivement vous etes sur la bonne voie.

Pour augmenter la hauteur de cellule, ajoutez

Rng.Height = sShape.Height

(de meme pour la largeur si jamais, attention est valable pour toute la colonne).

Ci-après le code complet :

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
        Rng.Height = sShape.Height
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

Je viens d'essayer, je ne vois pas de différence avec ce qui se passait avant.

Cependant, j'ai trouvé une autre méthode pour arriver à mon résultat.

Voici le code qui fonctionne si ça peut être utile à d'autres :

Sub InsertPictures()
'Update 20140513
    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    xColIndex = Application.ActiveCell.Column
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            Set sShape = ActiveSheet.Pictures.Insert(PicList(lLoop))
            With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                .LockAspectRatio = msoCTrue
                .Top = Rng.Top
                .Left = Rng.Left
                If Rng.Width < Rng.Height Then .Width = Rng.Width Else .Height = Rng.Height
            End With
            xRowIndex = xRowIndex + 1
        Next
    End If
End Sub

Bonne fin de journée à tous !

L'essentiel est que ça marche. Si le problème est résolu n'oubliez pas de sélectionner une réponse (par exemple votre dernier message), et de le valider en haut à droite pour "cloturer le fil" et le marquer comme résolu. Bonne soirée