XL 2016 Insertion d'une image à l'aide d'une macro dans une cellule fusionner

Combe P

XLDnaute Nouveau
Bonjour j’ai besoin d’insérer une photo se trouvant dans un dossier (pas toujours le même) a l’aide d’un bouton. Dans une cellule (C10) fusionner (le bouton et la cellule seront sur la même feuille), il faut que les dimensions s’adaptent à la cellule en respectant ses proportions. J’ai essayé des exemples mais sans résultat mon niveau est débutant je peux vous joindre mon fichier si nécessaire merci d’avance bonne soirée
 

Dudu2

XLDnaute Barbatruc
Bonjour,
J'ai codé cette fonction qui permet d'importer une image dans une cellule et de paramétrer sa position, entre autres.
VB:
'-----------------------------------
'Importer une image dans une feuille
'-----------------------------------
'Parameters:
'----------
'- ImageFullName    Image path and file name
'
'- Cell             Target Cell to place the image (can be merged cells)
'
'- ObjectName       Imposed name of the resulting Image Object or Shape Object
'
'- msoShape         If the image has to be placed in a Shape,
'                   Type of Shape (see https://docs.microsoft.com/en-us/office/vba/api/office.msoautoshapetype)
'                   Exemple: msoShapeRectangle
'
'- msoShapeBorderWeight     If msoShape specified, its border weight
'
'- msoShapeBorderColor      If msoShape specified, its border RGB color
'
'- InCell           True to place the image into the Cell
'                   False to place the image outside the Cell
'
' - InCellHMarginPercentage     If InCell = True, percentage of Cell Width for horizontal margin from Cell (the margin applies to left & right)
'
' - InCellVMarginPercentage     If InCell = True, percentage of Cell Height for vertical margin from Cell (the margin applies to top & bottom)
'
'- Align            If InCell = True, image position into the Cell
'                   - Keeps the original image proportions:
'                       "Top", "Bottom", "Left", "Right", "Centre" (défaut)
'                   - Modify image proportions:
'                       "Cover"
'
'                   If InCell = False, image top left corner position in relation to the Cell
'                   - Keeps the original image proportions:
'                       "TopLeft" (défaut), "TopRight", "BottomLeft", "BottomRight", "Centre"
'
' - ResizeRatio     If InCell = False, resize ratio to apply to the image
'
'Return:
'------
'- Created Image Object name or Shape Object name
'-----------------------------------
Function ImportImage(ByVal ImageFullName As String, _
                     ByVal Cell As Range, _
                     Optional ByVal ObjectName As String = vbNullString, _
                     Optional ByVal msoShape As String = vbNullString, _
                     Optional ByVal msoShapeBorderWeight As Single = 1, _
                     Optional ByVal msoShapeBorderColor As Long = 0, _
                     Optional ByVal InCell As Boolean = True, _
                     Optional ByVal InCellHMarginPercentage As Single = 0, _
                     Optional ByVal InCellVMarginPercentage As Single = 0, _
                     Optional ByVal Align As String = vbNullString, _
                     Optional ByVal ResizeRatio As Single = 1) As String
    
    Dim Pic As Picture
    Dim Shp As Shape
    Dim RatioWidth As Single
    Dim RatioHeight As Single
    Dim ZonePicTop As Single
    Dim ZonePicLeft As Single
    Dim ZonePicWidth As Single
    Dim ZonePicHeight As Single
    Dim Left As Single
    Dim Top As Single
    Dim S As String
    
    'Vérification nom de l'image
    If Len(Dir(ImageFullName)) = 0 Then Exit Function
    
    'Vérification des marges InCell
    With Cell.MergeArea
        If InCell Then
            If InCellHMarginPercentage >= 1 Or InCellVMarginPercentage >= 1 Then Exit Function
            ZonePicLeft = .Left + (.Width * InCellHMarginPercentage)
            ZonePicTop = .Top + (.Height * InCellVMarginPercentage)
            ZonePicWidth = .Width - 2 * (.Width * InCellHMarginPercentage)
            ZonePicHeight = .Height - 2 * (.Height * InCellVMarginPercentage)
        End If
    End With
    
    'Insertion de l'image sur l'ActiveCell
    Set Pic = ActiveSheet.Pictures.Insert(ImageFullName)

    '----------
    'Image size
    '----------
    'Image dans la cellule
    If InCell Then
        Select Case UCase(Align)
            Case "TOP", "BOTTOM", "LEFT", "RIGHT", "CENTRE"
                RatioWidth = Application.Min(ZonePicWidth / Pic.Width, ZonePicHeight / Pic.Height)
                Pic.ShapeRange.LockAspectRatio = msoTrue
            
            Case "COVER"
                RatioWidth = ZonePicWidth / Pic.Width
                RatioHeight = ZonePicHeight / Pic.Height
                Pic.ShapeRange.LockAspectRatio = msoFalse
            
            Case Else
                RatioWidth = Application.Min(ZonePicWidth / Pic.Width, ZonePicHeight / Pic.Height)
                Pic.ShapeRange.LockAspectRatio = msoTrue
        End Select
        
    'Image hors de la cellule
    Else
        RatioWidth = ResizeRatio
        Pic.ShapeRange.LockAspectRatio = msoTrue
    End If

    'Set image size
    Pic.Width = Pic.Width * RatioWidth
    If Pic.ShapeRange.LockAspectRatio = msoFalse Then Pic.Height = Pic.Height * RatioHeight

    '--------------
    'Image position
    '--------------
    'Image dans la cellule
    If InCell Then
    
        'Alignement dans la cellule
        Select Case UCase(Align)
            Case "TOP"
                Top = ZonePicTop
                Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
                
            Case "BOTTOM"
                Top = ZonePicTop + ZonePicHeight - Pic.Height
                Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
                
            Case "LEFT"
                Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
                Left = ZonePicLeft
            
            Case "RIGHT"
                Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
                Left = ZonePicLeft + ZonePicWidth - Pic.Width
                
            Case "CENTRE"
                Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
                Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
                
            Case Else
                Top = ZonePicTop + (ZonePicHeight - Pic.Height) / 2
                Left = ZonePicLeft + (ZonePicWidth - Pic.Width) / 2
        End Select
        
    'Image hors de la cellule
    Else
        With Cell.MergeArea
            'Alignement par rapport à la cellule
            Select Case UCase(Align)
                Case "TOPLEFT"
                    Left = .Left
                    Top = .Top
                    
                Case "TOPRIGHT"
                    Left = .Left + .Width
                    Top = .Top
                    
                Case "BOTTOMLEFT"
                    Left = .Left
                    Top = .Top + .Height
                
                Case "BOTTOMRIGHT"
                    Left = .Left + .Width
                    Top = .Top + .Height
                    
                Case "CENTRE"
                    Left = .Left + .Width / 2
                    Top = .Top + .Height / 2
                    
                Case Else
                    Left = .Left
                    Top = .Top
            End Select
        End With
    End If
    
    'Nom par défaut de l'objet à créer (Image ou Shape)
    S = Mid(ImageFullName, InStrRev(ImageFullName, "\") + 1)
    S = Mid(S, 1, InStrRev(S, ".") - 1)
  
    'L'image doit être placée dans un Shape
    If Len(msoShape) > 0 Then
        'Set Shp = Cell.Parent.Shapes.AddShape(msoShapeRectangle, Left, Top, pic.width, pic.height)
        Set Shp = Cell.Parent.Shapes.AddShape(msoShape, Left, Top, Pic.Width, Pic.Height)
        Shp.Line.Weight = msoShapeBorderWeight
        Shp.Line.ForeColor.RGB = msoShapeBorderColor
        Shp.Fill.UserPicture ImageFullName
        If Len(ObjectName) Then Shp.Name = ObjectName Else Shp.Name = S
        ImportImage = Shp.Name
        Pic.Delete
    'L'image doit rester indépendante
    Else
        Pic.Left = Left
        Pic.Top = Top
        If Len(ObjectName) Then Pic.Name = ObjectName Else Pic.Name = S
        ImportImage = Pic.Name
    End If
End Function

Un exemple d'utilisation...
 

Pièces jointes

  • VBA Ajouter Insérer Importer une photo image dans une cellule.xlsm
    25.8 KB · Affichages: 16
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour @Combe P @Dudu2

ma vielle version qui ne m'a jamais fait défaut
elle ne fait que ce que tu demande
je suggère a Dudu2 de modifier sa stratégie de redimensionnement
remettre a true le lockaspect ratio et ne redimensionnant qu'un coté et l'autre suivra
en effet j'ai eu des surprise avec sa méthode sur 2013 avec grand écran(bien que mathématiquement parlant le calcul est juste)
j'avoue ne pas comprendre pourquoi mais cet un fait
mieux vaut laisser excel faire si il sait faire ;)
 

Pièces jointes

  • copie Oldversion.xlsm
    22.4 KB · Affichages: 16
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
avec le calcul ratio abrégé de @Dudu2
j'ajoute le pourcentage de taille de la plage de destination en option
et la compatibilité pour picture et shape
la marge est appliquée au plus grand coté de la shape/picture


VB:
Sub loadImage()
    Dim pict As Picture, Fichier
    Fichier = Application.GetOpenFilename(FileFilter:=" Image File ( *.jpg;*.png;*gif;*.wmf;*.bmp), ( *.jpg*.png;*gif;*.wmf;*.bmp), images Files, *.*", FilterIndex:=1)
    If Fichier = False Then Exit Sub    'si on annule dans la boite de dialogue
    Set pict = Sheets(1).Pictures.Insert(Fichier)    'on insert l'image tel quel
    pict.Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
    'appel de la sub de placement et redimensionnement au niveau de la plage en 1er paramètre
    'le 2d argument est l'object picture
    'le 3° argument est le pourcentage de la taille de la plage de 0 a 100
    PlaceThePictureInCenterRange [C4].MergeArea, pict, 50    ' 50% de la taille de la plage de destination de 0 à 100
End Sub

Sub placeLaShapeBleue() 'test avec une shape
    Dim shap
    Set shap = ActiveSheet.Shapes("shapebleue")
    PlaceThePictureInCenterRange [C4].MergeArea, shap, 50    ' 50% de la taille de la plage de destination de 0 à 100
End Sub

Sub PlaceThePictureInCenterRange(rng As Range, Obj As Variant, Optional PercentMarge As Long = 100)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#, Wx#, Yx#
    Wx = rng.Cells(1).MergeArea.Width * (PercentMarge / 100)
    Yx = rng.Cells(1).MergeArea.Height * (PercentMarge / 100)
    Ratio = Application.Min(Wx / Obj.Width, Yx / Obj.Height)
    With Obj
        If TypeName(Obj) = "Shape" Then .LockAspectRatio = msoTrue Else .ShapeRange.LockAspectRatio = msoTrue
        .Width = .Width * Ratio
        .Top = rng.Top + ((rng.Cells(1).MergeArea.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Cells(1).MergeArea.Width - .Width) / 2)
    End With
End Sub
 

Dudu2

XLDnaute Barbatruc
Bonjour @patricktoulon,
J'espère que tu vas bien depuis la dernière fois.
Je reviens un peu par hasard sur ce sujet.
je suggère a Dudu2 de modifier sa stratégie de redimensionnement
remettre a true le lockaspect ratio et ne redimensionnant qu'un coté et l'autre suivra
Quand j'ai développé la fonction que j'ai présentée ci-dessus, c'était avec Office 2013 et je n'ai rien remarqué de particulier en appliquant le calculs de ratios. Je suis passé à 2016 depuis.
Dans cette fonction, c'est intentionnellement que je fais un Pic.ShapeRange.LockAspectRatio = msoFalse car selon l'option choisie (en l'occurrence paramètre Align="Cover") on ne doit PAS respecter les proportions de l'image et donc le ratio horizontal n'est pas le même que le vertical. Par conséquent la "stratégie de redimensionnement de Dudu2" est parfaitement adaptée aux possibilités que Dudu2 donne à l'appelant de la fonction et que tu ne peux pas avoir avec le LockAspectRation = True de ton code ;).
 

patricktoulon

XLDnaute Barbatruc
bonsoir @Dudu2

je vais bien
je suis passé sur un écran 41 pouce (107) et j'ai un décalage avec l'application du ratio sur le width et le height en lockapectratio false(pas de beaucoup mais ca dépasse)
et en auto avec le lockaspectratio true je n'ai pas le soucis
pourtant quand je contrôle les dims après elles sont bonnes
encore une histoire graphique ;)
 

Discussions similaires

Statistiques des forums

Discussions
311 713
Messages
2 081 808
Membres
101 819
dernier inscrit
lukumubarth