Redimensionner photos selon taille de la cellule

Y compris Power BI, Power Query et toute autre question en lien avec Excel
d
dannab
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 25 avril 2019
Version d'Excel : O365

Message par dannab » 22 mai 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 !
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'388
Appréciations reçues : 198
Inscrit le : 13 juin 2016
Version d'Excel : 2013 FR 64 bits

Message par thev » 22 mai 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
Avatar du membre
LouReeD
Contributeur
Contributeur
Messages : 5'774
Appréciations reçues : 239
Inscrit le : 14 octobre 2014
Version d'Excel : 2013 FR, 2016 FR
Contact :
Téléchargements : Mes applications

Message par LouReeD » 22 mai 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
Contributeur depuis peu ! 8-)
Quelques règles à lire ICI ;;)
______________________________________________________Vous pouvez allez faire un tour sur : Index de "Mes applications" ;;)
d
dannab
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 25 avril 2019
Version d'Excel : O365

Message par dannab » 24 mai 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
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'388
Appréciations reçues : 198
Inscrit le : 13 juin 2016
Version d'Excel : 2013 FR 64 bits

Message par thev » 24 mai 2019, 17:01

dannab a écrit :
24 mai 2019, 16:06
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
d
dannab
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 25 avril 2019
Version d'Excel : O365

Message par dannab » 24 mai 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
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message