XL 2013 Centrer en redimenssionnant une image dans une cellule en gardant les proportions

[Fred59240]

Bonjour,

Je me permets de vous solliciter à nouveau car je sèche sur le fait de réduire une image.
Je vous explique :

J'ai des images que j'insère dans une cellule en fonction d'un lien hypertexte.
Ces différentes images n'ont jamais la même taille.

Je voudrais, tout en gardant la proportion de l'image, que celles-ci soient centrées dans le haut de la cellule de destination. Les cellules de destination sont toutes de la même taille.
Il ne faut pas que les images dépassent de la cellule.

Taille de la cellule de destination : Hauteur : 100 et Largeur : 40

J'ai écrit une macro que vous trouverez ci-dessous :

For Each c In Selection
fich = c.Value
If fich <> "" Then
c.RowHeight = 100 'fixer la hauteur de ligne
ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Height = 84
If Height > 84 Then Height = 84
If .Width > 40 Then Height = 20
.Left = c.Offset(0, r).Left + 1
.IncrementLeft (ActiveCell.Width - Selection.ShapeRange.Width) / 2
.Top = c.Top + 2 'et positionner verticalement
End With
End If
Next c

Merci pour votre aide

Fred

 

[Lone-wolf]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

Bonjour Fred,

Avec cette macro, je peux redimentionner la taille de la cellule et l'image s'adapte à la cellule sans débordement.

Private Sub Image_Click()
Dim Pict As Object
Dim Pos As Range

For Each sh In Feuil2.Shapes
    If sh.Type <> 12 Then sh.Delete
Next sh

ActiveSheet.UsedRange.Select
    Selection.Copy
    Application.CutCopyMode = False
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Feuil2.Activate
    ActiveSheet.Range("a1").Activate
    ActiveSheet.Pictures.Paste.Select

Set Pos = ActiveSheet.Range("A1")
Set Pict = ActiveSheet.Pictures
With Pict
.Left = Pos.Left
.Top = Pos.Top
.Height = Pos.Height
.Width = Pos.Width

Selection.Placement = xlMove
If Selection.ShapeRange.Height <> Pos.Height Then
Selection.ShapeRange.Height = Pos.Height:
Selection.ShapeRange.LockAspectRatio = msoFalse
End If

If Selection.ShapeRange.Width <> Pos.Width Then
Selection.ShapeRange.Width = Pos.Width:
Selection.ShapeRange.LockAspectRatio = msoTrue
End If
End With
End Sub

 

[Fred59240]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

Merci lone-wolf,

Je teste ta macro et je reviens vers toi.

Fred

 

[Fred59240]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

J'ai regardé et je reviens vers toi.

En effet ce que je souhaite c'est le contraire, à savoir que l'image s'adapte à la cellule.
Que l'image soit centrée et dans le haut de la cellule, sans débordement et en gardant les proportions de l'image.

Merci - Fred

 

[Lone-wolf]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

Re Fred

à savoir que l'image s'adapte à la cellule

C'est bien ce que fais la macro, je ne comprends pas??? 😕

Ou alors: en supprimant le Ratio puis, Selection.ShapeRange.left = Selection.ShapeRange.left + 10. À tester

 

[Lone-wolf]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

Re Fred

voici un 2ème fichier. Inscrit le nom d'une des images en colonne A puis Enter. Est-ce celà que tu cherche à faire?

 

[Fred59240]

Re : Centrer en redimenssionnant une image dans une cellule en gardant les proportion

Oui ça marche super !!!

Merci de ton aide

Fred