EXCEL : insertion et paramétrage d'une image Résolu

Question

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

lermite222 · Answer

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+

lermite222 · Answer

Bonjour catman,
Une version plus élaborée sur ce tuto
A+

EXCEL : insertion et paramétrage d'une image

2 réponses

Newsletters