Redimensionner photos selon taille de la cellule

Le 22/05/2019 à 17:29

Bonjour!

J'ai une macro qui me permet d'insérer automatiquement des photos dans un tableau excel

  • Je selectionne en colonne des references;
  • La macro me demande dans quelle colonne je veux insérer les photos;
  • Elle insere les photos en tout petit au coin supérieur gauche de la cellule. Elle y arrive car toutes les photos sont stockées dans un repertoire avec comme nom reference.jpg
  • Enfin, elle me dit pour quelles references elle n'a pas trouvé.

Elle fonctionne super bien, mais j'aimerais qu'elle redimensionne chaque photo selon la hauteur de la cellule, en gardant les proportions bien sûr.

Des idées ?

Voici le code actuel:

Sub Macro_Photo()

Dim rngTmp As Range

Dim rowTmp As Range

Dim rngInsert As Range

Dim tmpFamily As String

Dim tmpPath As String

Dim tmpFile As String

Dim tmpFileOrig As String

Set rngTmp = Selection

tmpFile = "Ces articles n'existent pas en photo"

tmpFileOrig = tmpFile

Dim posColstr As String

Dim posCol As Integer

posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)

posCol = CInt(posColstr)

If posCol = 0 Then posCol = 1

For Each rowTmp In rngTmp.Rows

tmpFamily = Mid(rowTmp.Cells(1, 1), 4, 2)

tmpPath = "\\10.0.1.185\projects\COMMUN\PHOTOS skus" + "\" + CStr(rowTmp.Cells(1, 1)) + ".jpg"

If Dir(tmpPath) <> "" Then

ActiveSheet.Cells(rowTmp.Cells(1, 1).Row, rowTmp.Cells.Column).Select

ActiveSheet.Cells(Selection.Row, posCol).Select

ActiveSheet.Pictures.Insert(tmpPath).Select

dblFactor = rowTmp.Height / Selection.Height

Selection.Name = rowTmp.Cells(1, 1)

Selection.ShapeRange.ScaleWidth dblFactor, msoFalse, msoScaleFromTopLeft

Selection.ShapeRange.ScaleHeight dblFactor, msoFalse, msoScaleFromTopLeft

Else

tmpFile = tmpFile + vbCrLf + rowTmp.Cells(1, 1)

End If

Next rowTmp

If tmpFile <> tmpFileOrig Then

MsgBox tmpFile

End If

End sub

MERCI !

Le 22/05/2019 à 19:07

Bonsoir,

Essayer ce code :

Sub Macro_Photo()
    Dim rngTmp As Range, rowTmp As Range, rngInsert As Range, cell_photo As Range
    Dim tmpFamily As String, tmpPath As String, tmpFile As String, tmpFileOrig As String
    Dim img As Object

    Set rngTmp = Selection
    tmpFile = "Ces articles n'existent pas en photo"
    tmpFileOrig = tmpFile

    Dim posColstr As String
    Dim posCol As Integer

    posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
    posCol = CInt(posColstr)

    If posCol = 0 Then posCol = 1

    For Each rowTmp In rngTmp.Rows
        tmpFamily = Mid(rowTmp.Cells(1, 1), 4, 2)

        tmpPath = "\\10.0.1.185\projects\COMMUN\PHOTOS skus" + "\" + CStr(rowTmp.Cells(1, 1)) + ".jpg"
        If Dir(tmpPath) <> "" Then
            Set cell_photo = rowTmp.Columns(1)
            Set img = ActiveSheet.Shapes.AddPicture(tmpPath, True, True, cell_photo.Left, cell_photo.Top, cell_photo.Width, cell_photo.Height)
            img.Name = rowTmp.Columns(1)
        Else
            tmpFile = tmpFile + vbCrLf + rowTmp.Cells(1, 1)
        End If
    Next rowTmp

    If tmpFile <> tmpFileOrig Then MsgBox tmpFile

End Sub
Le 22/05/2019 à 19:11

Bonsoir,

c'est un peu le principe de ma dernière application : LARCIN

Pour simuler la rotation des roues, les images sont affichées petite, puis moyenne puis grande, pour cela j'ai "formaté" la hauteur des cellules avec 3 tailles, et je demande de mettre l'image à la taille de la hauteur de la cellule.

Le code de mise en place des images :

Sub Image(ByVal RgImage As Range, ByVal NomImage As String, N_Img As String)
    ' permet de télécharger une image, et de la positionner sur une cellule donnée avec les dimensions de cette dernière en hauteur
    Dim Rg As Range, Image As Picture
    Set Rg = Feuil1.Range(RgImage.Address)
    With Rg
        Set Image = Feuil1.Pictures.Insert(NomImage)
    End With
    With Image
        .Name = N_Img
        .Height = Rg.Height - 6
        .Left = Rg.Left + (Rg.Width - .Width) / 2
        .Top = Rg.Top + 3
    End With
    Set Rg = Nothing
End Sub

Le code d'appel :

Image Range(Ad_Roue1(0)), ThisWorkbook.Path & "\_Thème0\" & Roue1(Img_Roue1) & ".png", "R1_0"

Si cela peut vous aider...

@ bientôt

LouReeD

Le 24/05/2019 à 16:06

Merci pour vos réponses.

Je me cale sur la proposition de Thev... merci d'avoir adapté ma macro et du temps que vous avez pu y passer.

J'ai 2 soucis:

. Les photos s'insèrent systématiquement sur la colonne où sont sélectionnées les références => L'input box jusque là demandait la colonne ou insérer les photos et insérait les photos sur la bonne colonne selon la réponse là l'input box.

. Les photos perdent de leur proportions: je voudrais que leur hauteur change selon la hauteur de la cellule, mais en gardant la proportion initiale. C'est possible ?

Encore merci,

Fred

Le 24/05/2019 à 17:01
dannab a écrit :

J'ai 2 soucis:

ci-jointe modification

Sub Macro_Photo()
    Dim rngTmp As Range, rowTmp As Range, rngInsert As Range, cell_photo As Range
    Dim tmpFamily As String, tmpPath As String, tmpFile As String, tmpFileOrig As String
    Dim img As Object

    Set rngTmp = Selection
    tmpFile = "Ces articles n'existent pas en photo"
    tmpFileOrig = tmpFile

    Dim posColstr As String
    Dim posCol As Integer

    posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
    posCol = CInt(posColstr)

    If posCol = 0 Then posCol = 1

    For Each rowTmp In rngTmp.Rows
        tmpFamily = Mid(rowTmp.Cells(1, 1), 4, 2)

        tmpPath = "\\10.0.1.185\projects\COMMUN\PHOTOS skus" + "\" + CStr(rowTmp.Cells(1, 1)) + ".jpg"
        If Dir(tmpPath) <> "" Then
            posCol = posCol - rowTmp.Column + 1
            Set cell_photo = rowTmp.Columns(posCol)
            Set img = ActiveSheet.Shapes.AddPicture(tmpPath, True, True, cell_photo.Left, cell_photo.Top, -1, -1)
            With img
                .Name = rowTmp.Columns(1)
                .LockAspectRatio = -1
                .Width = cell_photo.Width
                .Height = cell_photo.Height
            End With
        Else
            tmpFile = tmpFile + vbCrLf + rowTmp.Cells(1, 1)
        End If
    Next rowTmp

    If tmpFile <> tmpFileOrig Then MsgBox tmpFile

End Sub
Le 24/05/2019 à 18:34

Malheureusement, cela bugue... 1ere photo nickel, puis la 2eme s'insere dans la 1ere colonne, et ensuite j'ai un message d'erreur...

J'ai réussi de mon côté, pas parfait mais ca le fait.

Merci beaucoup pour votgre aide en touit cas,

Fred

Rechercher des sujets similaires à "redimensionner photos taille"