Microsoft 365 Redimensionnement image

[fredannab]

Bonjour

J'ai une macro photo qui fonctionne bien, j'y suis presque mais... je voudrais qu'une fois insérée l'image se redimensionne selon la taille de la cellule en gardant ses proportions.

J'ai le code si-dessous. Quelqu'un peut m'aisder svp ?

Merci!

Sub Macro_Photo_FRED()


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
Dim cell_photo As Range
Dim img As Object
Dim dblFactorH As Variant
Dim Pic As Shape

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
        Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=tmpPath, _
        Linktofile:=msoFalse, SaveWithDocument:=msoTrue, Left:=ActiveCell.Left, _
        Top:=ActiveCell.Top, Width:=-1, Height:=-1)
        
  
 With Pic
                Pic.LockAspectRatio = msoTrue
                Pic.Width = ActiveCell.Width
                Pic.Left = ActiveCell.Left
                Pic.Top = ActiveCell.Top
                Pic.Height = ActiveCell.Height
            End With

        
            
    Else
        tmpFile = tmpFile + vbCrLf + rowTmp.Cells(1, 1)
    End If
Next rowTmp

If tmpFile <> tmpFileOrig Then
    MsgBox tmpFile
End If


End Sub

 

[Dudu2]

Bonjour,

l'image se redimensionne selon la taille de la cellule en gardant ses proportions.

Tu ne peux pas à la fois redimensionner l'image à la taille de la cellule comme tu le fais:

Pic.Width = ActiveCell.Width
Pic.Left = ActiveCell.Left
Pic.Top = ActiveCell.Top
Pic.Height = ActiveCell.Height

et garder les proportions originales de l'image, c'est contradictoire.

Tu la cales soit sur la largeur de la cellule, soit sur la hauteur pour garder ses proportions quitte à ensuite ajuster la largeur de colonne ou la hauteur de ligne.

 

[patricktoulon]

bonjour

j''ai une macro photo qui fonctionne bien, j'y suis presque mais... je voudrais qu'une fois insérée l'image se redimensionne selon la taille de la cellule en gardant ses proportions.

J'ai le code si-dessous. Quelqu'un peut m'aisder svp ?

purée de purée de purée !!!!!
c'est si difficile que ca d'utiliser le moteur de recherche de XLD

centrer une image dans un range en toute circonstances quel que soit le ratio (range/image)

bonjour a tous voici deux méthode avec exemple pour centrer une image sur un range la méthode que j'appelle directe en effet j'agit directement sur l'image en bloquant l'apect ratio...

www.excel-downloads.com

j'ai tapé "centrer une image" dans le moteur de recherche
et voila le résultat