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

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
 

Lone-wolf

XLDnaute Barbatruc
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

XLDnaute Nouveau
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

XLDnaute Barbatruc
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??? :confused:

Ou alors: en supprimant le Ratio puis, Selection.ShapeRange.left = Selection.ShapeRange.left + 10. À tester
 
Dernière édition:

Lone-wolf

XLDnaute Barbatruc
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?
 

Pièces jointes

  • Insertion Images.zip
    31.5 KB · Affichages: 73
  • Insertion Images.zip
    31.5 KB · Affichages: 76
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
315 088
Messages
2 116 089
Membres
112 658
dernier inscrit
doro 76