Redimensionner photos selon taille de la cellule
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 !
- Messages
- 4'087
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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
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
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
- Messages
- 4'087
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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
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