1 pièce(s) jointe(s)
Insertion image avec redimensionnement
Bonjour je cale sur une problème.
je dois insérer une image dans une feuille Excel avec la dimension d'une plage de cellule (ça c'est bon)
garder la bonne proportion de la photo (c'est bon aussi)
mais lorsque la photo dépasse une certaine largeur (largeur de la feuille) Excel la redimensionne tout seul et du coup l'image est déformée
voici un capture pour illustrer :
Pièce jointe 434191
Pour une image de petite taille pas de problème, dès que l'image est plus grande comme les deux personnes l'image se tasse
voici mon code
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
| Sub Image_AjoutT1a()
On Error GoTo Erreur
Call Image_SupT1a 'supprime image avant
Feuil6.Unprotect Password:=Worksheets("TBL").Range("E2") 'Acceuil
Sheets("Accueil").Select
L = Range("B14:C17").Left
T = Range("B14:C17").Top
W = Range("B14:C17").Width
H = Range("B14:C17").Height 'hauteur de l'image
image = Application.GetOpenFilename(FileFilter:="Picture,*.JPG,Picture,*.JPEG,Picture,*.GIF,Picture,*.BMP")
If image <> False Then
Set sq = Sheets("Accueil").Shapes.AddPicture(image, True, True, L, T, -1, -1)
sq.Name = "ImageT1a"
Largeur = sq.Width
Hauteur = sq.Height
If W / Largeur < H / Hauteur Then
sq.Width = W
Else
sq.Height = H
End If
sq.Left = L
sq.Top = T |
est-il possible dans l'import de diminuer la taille sans changer la proportion ? Ou dans .Shapes.AddPicture(image, True, True, L, T, -1, -1) à la place de -1 de mettre la condition de dessous ?
Merci
