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

  • Initiateur de la discussion Initiateur de la discussion Fred59240
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Fred59240

XLDnaute Nouveau
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
 
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
 
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
 
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
 
Dernière édition:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
485
Réponses
11
Affichages
742
Retour