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

Fred59240 · 21 Avril 2016

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 · 21 Avril 2016

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.

Code:

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 · 21 Avril 2016

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 · 21 Avril 2016

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 · 21 Avril 2016

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 · 21 Avril 2016

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 · 21 Avril 2016

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

Oui ça marche super !!!

Merci de ton aide

Fred

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

Fred59240

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Fred59240

XLDnaute Nouveau

Fred59240

XLDnaute Nouveau

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Pièces jointes

Fred59240

XLDnaute Nouveau

Discussions similaires