XL 2013 Insertion photo et redimensionner selon taille de la cellule

[fredannab]

Bonjour,

J'ai ce code qui fonctionne bien pour insérer des photos:

Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=tmpPath, _
Linktofile:=msoFalse, SaveWithDocument:=msoTrue, Left:=ActiveCell.Left, _
Top:=ActiveCell.Top, Width:=ActiveCell.Width, Height:=ActiveCell.Height)

Où Pic est la photo inserée...

Elle arrive bien en haut de la cellule, à gauche de la cellule et avec la hauteur de la cellule, mais la photo est élargie pour être aussi large que la cellule, bien sur...
Je voudrais que la photo au final ait une Width telle que les proportions initiales de la photo soient maintenues... Je seche !

Avez-vous une idée ?
Merci !

 

[patricktoulon]

bonjour
j'ai répondu de deux façons a cette question très récemment


voici la méthode que j’appelle "méthode directe"

'sub de placement et centrage de l'image  dans la range en parametre tout en respectant son  ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
    Dim ratio#, W#, H#
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        W = Rng.Width       ' width  range
        H = Rng.Height      ' height range
        If (W / H < ratio) Then
            .Width = W - space    'en redimentionant le width le height se redimentionne automatiquement
        Else    'ou
            .Height = H - (space / ratio)    'en redimentionant le height le width se redimentionne automatiquement
        End If
        .Left = Rng.Left + ((Rng.Width - .Width) / 2)
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

on l'appelle comme ca
fichier étant le chemin complet du fichier image bien sur

 Set Pict = Sheets(1).Pictures.Insert(Fichier)    'on insert l'image tel quel
    Pict.Name = "img3"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
    place_l_image_dans Range("C14:C15"), Pict, 5    'appel de la sub de placement et redimentionnement au niveau de la plage en 1er parametre

MAINTENANT LA METHODE INDIRECTE
elle consiste a calculer les dimensions en fonction des ratio range/image
cette fois ci c'est une fonction

Function Dimention_position(Rng, Pict As Picture, Optional space As Double = 0)
    Dim Wr&, Hr&, W&, H&, L&, T&, Sp1&, Sp2&, ratio&
    With Pict
        ratio = .Width / .Height     ' calcul ratio
        Wr = Rng.Width: Hr = Rng.Height      ' width  range' height range
        If (Wr / Hr < ratio) Then
            '.Width = wr - space
            W = Wr - space: H = .Height / (.Width / (Wr - (space / ratio)))
        Else
            '.Height = Hr - (space / ratio)
            H = Hr - (space / ratio): W = .Width / ((.Height / (Hr - space)))
        End If
        L = Rng.Left + ((Wr - W) / 2): T = Rng.Top + ((Hr - H) / 2)
    End With
    Dimention_position = Array(W, H, T, L - Sp1)
End Function

et on l'utilise comme ca dans un sub

Set Pict = Sheets(2).Pictures.Insert(Fichier)    'on insert l'image tel quel
     dp = Dimention_position(Range("J8:K10"), Pict, 4)
    With Pict
        .Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        .Top = dp(2): .Left = dp(3): .Width = dp(0): .Height = dp(1)
        '.Placement = 1
    End With

si joint un classeur en exemple démontrant les deux méthodes
avec en plus la réduction du poids de l'image si c'est nécessaire

 

[MJ13]

Bonjour Fred, Patrick

Merci Patrick, c'est assez technique.

Sinon, J'ai cette routine que j'avais développé pour insérer des images dans une cellule avec mise à l'echelle de la cellule.

Sub Insère_ImageDansCellule_V2020_OK()
'MJ le 22/01/2020
    'On Error Resume Next
    'Permet d'insérer une image dans une cellule
    ChoixSauveImgs = "O" ' InputBox("voulez-vous copier les images dans le classeur (o/n)?"
    Application.ScreenUpdating = False
    'Lien et Nom du fichier
       Fichier = "C:\Temp\Test.jpg"
       'Fichier = "C:\Temp\Test2.jpg"
        ActiveSheet.Pictures.Insert(Fichier).Select
    'Coupe et place l'image dans la cellule en la redimensionnat à la taille de la cellule avec marge basse de 12
    DoEvents
    Application.ScreenUpdating = False
    Rap = Selection.Width / Selection.Height
        Selection.Cut
MargeBasse = 12
'https://docs.microsoft.com/fr-fr/office/vba/api/excel.shapes.addpicture
         If Rap > 1 Then Set Shp = ActiveSheet.Shapes.AddPicture(Fichier, msoTrue, msoCTrue, ActiveCell.Left + 2, ActiveCell.Top + 2, Int((ActiveCell.Width - MargeBasse)), (ActiveCell.Width - MargeBasse) / Rap).Select
         If Rap <= 1 Then Set Shp = ActiveSheet.Shapes.AddPicture(Fichier, msoTrue, msoCTrue, ActiveCell.Left + 2, ActiveCell.Top + 2, Int((ActiveCell.Height - MargeBasse) * Rap), (ActiveCell.Height - MargeBasse)).Select
        
  Selection.Placement = xlMoveAndSize
  'Choix pour sauver l'image en dur dans le fichier (O) ou en lien (N)
  If ChoixSauveImgs = "N" Or ChoixSauveImgs = "n" Then Application.CutCopyMode = False: Exit Sub
  'Format image GIF JPG PNG ou métafichier amélioré à changer dans "Image (GIF)"
If ChoixSauveImgs = "O" Or ChoixSauveImgs = "o" Then Selection.Cut: ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False, DisplayAsIcon _
        :=False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[patricktoulon]

bonsoir
Mj13
donc si j'ai bien compris on add une image on calcule le rapport que j’appelle (ratio ) ensuite la coupe
et on Re!!! add le même fichier image en le redimensionnant

WAOUAOU!!!!!!

je vois les liens Microsoft
et moi je pense que le cannabis doit être libre dans les structures de bill gate

ils sont toqués chez bil

d'autant plus que c'est loin d’être suffisant
le principe nécessaire a cette opération il est simple
on redime limage selon les ratio du range ET !!!!!! de l'image

 With Pict
        'on empeche la deformation avec lockapectratio
        .ShapeRange.LockAspectRatio = msoTrue    ' lock le ratio indéformable
       
        ratio = .Width / .Height     ' calcul ratio de l'image
        Wr = Rng.Width: Hr = Rng.Height      ' width  range' height range
        
        If (Wr / Hr < ratio) Then'si le ratio widthrange par heightrange est plus petit que le ratioImage
            '.Width = wr - space 'on redimensionne que le width
    else 'sinon '
     '.Height = Hr - (space / ratio)' on redimensionne que le height '
    end if

et tu n'a besoins de rien de plus
je te remercie pour cet exemple
mais pour moi c'est pas propre et limpide comme principe
je suis vraiment étonné que tu ai trouvé ça chez Microsoft