Microsoft 365 Redimensionner photo selon taille de la cellule

[fredannab]

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 !

End Sub