EXCEL : insertion et paramétrage d'une image
Résolu
Nepyim
Messages postés
7
Statut
Membre
-
lermite222 Messages postés 9042 Statut Contributeur -
lermite222 Messages postés 9042 Statut Contributeur -
Bonjour,
Je cherche à insérer une image dans une cellule fusionnée. J’ai lu beaucoup de discussions sur le sujet et j’en tiré la macro suivante :
Sub insere_image()
Dim ficimg As String, Ad As String
Ad = Selection.Address
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
If ficimg = "Faux" Then Exit Sub
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
'Pas besoin, c'est fait automatiquement sur la sélection :
'.Top = Range(Ad).Top ' haut de la cellule
'.Left = Range(Ad).Left ' gauche de la cellule
.Height = Range(Ad).Height ' hauteur des cellules fusionnées
.Width = Range(Ad).Width ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
End Sub
Ça marche plutôt bien mais j’ai quelques souhaits complémentaires que je ne parviens pas à résoudre :
1/ je souhaite que l’image garde ses proportions d’origine (là, ça devrait aller)
2/ je souhaite que la taille de l’image soit ajustée à la taille de la cellule fusionnée en fonction de sa plus grande dimension. (C’est-à-dire : étirer l’image jusqu’à ce que sa hauteur corresponde à la hauteur de la cellule ou étirer l’image jusqu’à ce que sa largeur corresponde à la largeur de la cellule)
3/ je souhaite que sur l’autre dimension (que celle ajustée à la cellule) soit centrée sur la cellule
Merci d’avance pour vos bons conseils
Je cherche à insérer une image dans une cellule fusionnée. J’ai lu beaucoup de discussions sur le sujet et j’en tiré la macro suivante :
Sub insere_image()
Dim ficimg As String, Ad As String
Ad = Selection.Address
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
If ficimg = "Faux" Then Exit Sub
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
'Pas besoin, c'est fait automatiquement sur la sélection :
'.Top = Range(Ad).Top ' haut de la cellule
'.Left = Range(Ad).Left ' gauche de la cellule
.Height = Range(Ad).Height ' hauteur des cellules fusionnées
.Width = Range(Ad).Width ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
End Sub
Ça marche plutôt bien mais j’ai quelques souhaits complémentaires que je ne parviens pas à résoudre :
1/ je souhaite que l’image garde ses proportions d’origine (là, ça devrait aller)
2/ je souhaite que la taille de l’image soit ajustée à la taille de la cellule fusionnée en fonction de sa plus grande dimension. (C’est-à-dire : étirer l’image jusqu’à ce que sa hauteur corresponde à la hauteur de la cellule ou étirer l’image jusqu’à ce que sa largeur corresponde à la largeur de la cellule)
3/ je souhaite que sur l’autre dimension (que celle ajustée à la cellule) soit centrée sur la cellule
Merci d’avance pour vos bons conseils
A voir également:
- EXCEL : insertion et paramétrage d'une image
- Liste déroulante excel - Guide
- Word et excel gratuit - Guide
- Déplacer colonne excel - Guide
- Si ou excel - Guide
- Excel trier par ordre croissant chiffre - Guide
2 réponses
Bonjour,
Si j'ai bien compris, j'ai modifié mon code pour garder le ratio dans toutes les circonstances, c'est un peu plus compliqué.
tu dit...
A+
Si j'ai bien compris, j'ai modifié mon code pour garder le ratio dans toutes les circonstances, c'est un peu plus compliqué.
Sub insere_image_ratio()
Dim ficimg As String, Ad As String
Dim MemW As Long, MemH As Long, T As Integer, L As Integer
Dim Lg As Integer, HT As Integer, RatioCell As Single
Dim CellH As Long, CellW As Long, RatioHz As Single, RatioVt As Single
Ad = Selection.Address
CellH = Selection.Height
CellW = Selection.Width
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix nom du fichier
If ficimg = "Faux" Then Exit Sub
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
With Selection.ShapeRange
MemW = .Width: MemH = .Height
'adapte les ratio
If MemH < CellH And MemW < CellW Then
'l'image < cellule
RatioHz = MemH / CellH
RatioVt = MemW / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (CellW / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW > CellW Then
'l'image > cellule
RatioHz = CellH / MemH
RatioVt = CellW / MemW
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW < CellW Then
'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
ElseIf MemH < CellH And MemW > CellW Then
'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
Else
Stop ' pas prévu ?
End If
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Range(Ad).Top + T ' haut de la cellule
.Left = Range(Ad).Left + L ' gauche de la cellule
.Height = HT
.Width = Lg ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
End Sub
tu dit...
A+
j'ai testé et ça a marché pile poil comme je le souhaitais.
Je n'ai pas trop regardé le code pour le moment (le copier-coller ça a du bon) mais j'y ai vu ce que je pensais, à savoir le calcul sur les dimensions d'image et dimensions de cellule afin d'ajuster le tout... J'avais un peu pensé à cette méthode sans l'avoir encore testée parce que j'osais espérer qu'il existait une fonction du genre 'centrer' ou 'ajuster'.
En tous cas, merci beaucoup pour cette aide aussi fructueuse que rapide!
A bientôt peut-être