XL 2013 VBA Insérer des images d'un dossier

[Jouxte]

Bonjour à toutes et tous,

J'utilise un code VBA trouvé sur Internet qui me permet d'insérer des photos dans mon fichier Excel.
Je souhaiterai conserver l'homothétie de la photo et la centrer dans la cellule. (LockAspectRatio = msoTrue)

Par avance merci pour votre aide

 

[patricktoulon]

bonsoir

centrer une image dans un range en toute circonstances quel que soit le ratio (range/image)

bonjour a tous voici deux méthode avec exemple pour centrer une image sur un range la méthode que j'appelle directe en effet j'agit directement sur l'image en bloquant l'apect ratio...

excel-downloads.com

 

[Jouxte]

Bonjour patricktoulon,
Merci pour cette réponse rapide.
Comment intégrer ces codes dans mon exemple ?

 

[patricktoulon]

ben c'est marrant mon code est deja intégré tout du moins une de mes anciens code dans insererphoto
ca veut dire que normalement tu a compris le principe

sinon pas la plus récente mais fonctionnelles tout de même

Sub InserImages()

Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        'Selection.ShapeRange.LockAspectRatio = msoTrue
        xRowIndex = xRowIndex + 1
    place_l_image_dans Rng, sShape
   
    Next
End If
End Sub
Sub SuppImg()
ActiveSheet.Pictures.Delete
End Sub


'patricktoulon
'version 2021 en agissant directement sur l'image
Sub place_l_image_dans(Rng As Range, Shp As Picture)
    Dim x&
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        x = (Rng.Width / Rng.Height) < (.Width / .Height) 'comparaison des ratios
        'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
        If x Then .Width = Rng.Width Else .Height = Rng.Height
        .Left = Rng.Left   + ((Rng.Width - .Width) / 2)'débloquer si l'image doit etre au centre horizontalement
        .Top = Rng.Top   + ((Rng.Height - .Height) / 2)'débloquer si l'image doit etre au centre verticalement
        .Placement = 1
    End With
End Sub

 

[Jouxte]

Ton code avec insérerphoto fonctionne bien.
Mais InsérerImages ne fonctionne pas.
Je viens d'essayer ton code mais l'homothétie n'est pas respectée. L'image est étirée aux 4 coins de la cellule

 

[patricktoulon]

c'est par ce que tu n'emploie pas la bonne méthode pour insérer les image
tu empoie addpicture

   Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)

donc tu les dimensionne déjà avant de passer par la fonction comment veux tu qu’après ma fonction fasse son boulot

il faut utiliser la méthode pictures.insert

 Set sShape = ActiveSheet.Pictures.Insert(PicList(lloop))

comme tu peux le voir elle n'est pas dimensionnée
c'est après que l' on passe par ma fonction
j'ai donc tout repris

Sub InserImages()
    Dim PicList(), Rng As Range, sShape As Picture
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    Set Rng = Selection.Cells(1)
    If Not IsArray(pictlist) Then pictlist = Array(pictlist)
    For lloop = LBound(PicList) To UBound(PicList)
        Set sShape = ActiveSheet.Pictures.Insert(PicList(lloop))
        place_l_image_dans Rng, sShape
        Set Rng = Rng.Offset(1)
    Next
End Sub
Sub SuppImg()
    ActiveSheet.Pictures.Delete
End Sub


'patricktoulon
'version 2021 en agissant directement sur l'image
Sub place_l_image_dans(Rng As Range, Shp As Picture)
    Dim x&
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        x = (Rng.Width / Rng.Height) < (.Width / .Height)    'comparaison des ratios
        'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
        If x Then .Width = Rng.Width Else .Height = Rng.Height
        .Left = Rng.Left + ((Rng.Width - .Width) / 2)
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

voila

 

[Jouxte]

C'est magique.Merci beaucoup beaucoup