Sujet Précédent Sujet Suivant

EXCEL : insertion et paramétrage d'une image

Résolu/Fermé
Nepyim Messages postés 7 Date d'inscription samedi 22 novembre 2003 Statut Membre Dernière intervention 3 décembre 2008 - 2 déc. 2008 à 09:21
lermite222 Messages postés 8724 Date d'inscription dimanche 8 avril 2007 Statut Contributeur Dernière intervention 22 janvier 2020 - 25 janv. 2011 à 20:03
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
A voir également:

2 réponses

Réponse 1 / 2
lermite222 Messages postés 8724 Date d'inscription dimanche 8 avril 2007 Statut Contributeur Dernière intervention 22 janvier 2020 1 190
2 déc. 2008 à 12:01
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é. 
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+
0
Nepyim Messages postés 7 Date d'inscription samedi 22 novembre 2003 Statut Membre Dernière intervention 3 décembre 2008
3 déc. 2008 à 09:51
formidable !

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
0
Catman
25 janv. 2011 à 13:18
Excellente macro, marche parfaitement.. Merci!
0
Réponse 2 / 2
lermite222 Messages postés 8724 Date d'inscription dimanche 8 avril 2007 Statut Contributeur Dernière intervention 22 janvier 2020 1 190
25 janv. 2011 à 20:03
Bonjour catman,
Une version plus élaborée sur ce tuto
A+
0