XL 2013 Insertion d'image

Marcodon

XLDnaute Nouveau
Bonjour,

J'utilise la macro ci-dessous pour insérer une image dans une cellule.

Sub LinkToImage()
For Each cel In Selection
cel.Offset(0, 2).Select
cel.Offset(0, 2).RowHeight = 100
cel.Offset(0, 2).ColumnWidth = 14

Set Image = ActiveSheet.Pictures.Insert(cel.Value)

With Image
.ShapeRange.LockAspectRatio = msoFalse
.Height = Application.CentimetersToPoints(3)
.Width = Application.CentimetersToPoints(2)
.Width = cel.Offset(0, 2).Width
.Height = cel.Offset(0, 2).Height
.Left = cel.Offset(0, 2).Left
.Top = cel.Offset(0, 2).Top


End With

Next cel

End Sub


Mais je souhaiterais que cette image se redimensionne afin que ses bords ne touchent pas les bords de sa cellule (ceci afin qu'elle reste en sa position lors d'un tri)
Et là je reconnais mon impuissance.
D'où ma sollicitation auprès de vous.

Merci par avance de vous pencher sur mon problème.
 

patricktoulon

XLDnaute Barbatruc
Bonjour
un simple calcul et comparaison de ratio de l'image/range
l'image est centrée dans le range quelque soit sa taille et son ratio et j'ai mis 4 pour ne pas qu'elle touche les bords
VB:
Sub place_l_image_dans(rng As Range, Shp As Picture)
      With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock le ratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = rng.Width       ' width  range
        h = rng.Height      ' height range
        If (w / h < ratio) Then
            .Width = w - 4
        Else
            .Height = h - (4 / ratio)
        End If
        .Left = rng.Left + ((rng.Width - .Width) / 2)
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub
demo
demo3.gif
 

MJ13

XLDnaute Barbatruc
Bonjour à tous

Je trouve le code de Patrick très intéressant. :)

Par contre si on a une cellule et qu'on ne veut pas modifier la taille de la cellule, quel code dans place_l_image_dans conviendrait? ex: cellule de 200 pixels de large sur 150 pixels de haut.

Sinon, avec le code de départ LinkToImage, quand on met une image dans une cellule, elle se retrouve en lien dans le fichier et si on déplace ce fichier, les images ne seront plus disponibles. Il faudra copier l'image en collage spécial en Jpg ou Png pour qu'il soit transposable dans un autre média.
 

patricktoulon

XLDnaute Barbatruc
Bonjour à tous

Je trouve le code de Patrick très intéressant. :)

Par contre si on a une cellule et qu'on ne veut pas modifier la taille de la cellule, quel code dans place_l_image_dans conviendrait? ex: cellule de 200 pixels de large sur 150 pixels de haut.

Sinon, avec le code de départ LinkToImage, quand on met une image dans une cellule, elle se retrouve en lien dans le fichier et si on déplace ce fichier, les images ne seront plus disponibles. Il faudra copier l'image en collage spécial en Jpg ou Png pour qu'il soit transposable dans un autre média.

de retour nouveau pc nouveau écran

bonjour mj13
cette méthode n'a aucune restriction elle place l'image redimensionnée au max possible d'une range et la centre et c'est tout les dimention image ou range presque on s'en fout en fait ;)

edit


Par contre si on a une cellule et qu'on ne veut pas modifier la taille de la cellule, quel code dans place_l_image_dans conviendrait?
ou vous voyez dans la sub que je modifie les dimensions du range en paramètre???????????????????

:rolleyes:
 
Dernière édition:

MJ13

XLDnaute Barbatruc
Re

Oui, en effet, j'ai fait ce code qui a l'air de fonctionner. :)

J'ai dû faire une boulette, j'avais dû laisser les premières lignes de code. :mad:

VB:
Sub LinkToImage()
'code Marcodon & PatrickToulon le 08/10/2019
For Each cel In Selection
'cel.Offset(0, 2).Select
'cel.Offset(0, 2).RowHeight = 100
'cel.Offset(0, 2).ColumnWidth = 14
Set Image = ActiveSheet.Pictures.Insert(cel.Value)
With Image
'.ShapeRange.LockAspectRatio = msoFalse
'.Height = Application.CentimetersToPoints(3)
'.Width = Application.CentimetersToPoints(2)
'.Width = cel.Offset(0, 2).Width
'.Height = cel.Offset(0, 2).Height
'.Left = cel.Offset(0, 2).Left
'.Top = cel.Offset(0, 2).Top
'With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock le ratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = cel.Width       ' width  range
        h = cel.Height      ' height range
        If (w / h < ratio) Then
            .Width = w - 4
        Else
            .Height = h - (4 / ratio)
        End If
        .Left = cel.Left + ((cel.Width - .Width) / 2)
        .Top = cel.Top + ((cel.Height - .Height) / 2)
        .Placement = 1
    'End With
End With
Next cel
End Sub

Ce qui pourrait donner ce code, bien que le collage met l'image en GIF en haut de la cellule:

VB:
Sub LinkToImage()
For Each cel In Selection
cel.Select
Set Image = ActiveSheet.Pictures.Insert(cel.Value)
With Image
        .ShapeRange.LockAspectRatio = msoTrue    ' lock le ratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = cel.Width       ' width  range
        h = cel.Height      ' height range
        If (w / h < ratio) Then
            .Width = w - 4
        Else
            .Height = h - (4 / ratio)
        End If
        .Left = cel.Left + ((cel.Width - .Width) / 2)
        .Top = cel.Top + ((cel.Height - .Height) / 2)
        .Placement = 1
    Image.Select
    Selection.Copy
    Selection.Delete
    ActiveSheet.PasteSpecial Format:="Image (GIF)" ', Link:=False
End With
Next cel
End Sub
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour
il faudra m"expliquer a quoi ca sert cela
VB:
 Image.Select
    Selection.Copy
    Selection.Delete
    ActiveSheet.PasteSpecial Format:="Image (GIF)" ', Link:=False
si le probleme est que tu ne veux que du gif dans tes images fait le avant et c'est tout

Code:
Sub LinkToImage()
For Each cel In Selection
cel.Select
Set Image = ActiveSheet.Pictures.Insert(cel.Value)
 image.Copy
 image.Delete
 ActiveSheet.PasteSpecial Format:="Image (GIF)" ', Link:=False
set image =activesheet.pictures(activesheet.pictures.count)
With Image
        .ShapeRange.LockAspectRatio = msoTrue    ' lock le ratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = cel.Width       ' width  range
        h = cel.Height      ' height range
        If (w / h < ratio) Then
            .Width = w - 4
        Else
            .Height = h - (4 / ratio)
        End If
        .Left = cel.Left + ((cel.Width - .Width) / 2)
        .Top = cel.Top + ((cel.Height - .Height) / 2)
        .Placement = 1
  End With
Next cel
End Sub
mais encore une fois je n'en vois pas l’intérêt
 

MJ13

XLDnaute Barbatruc
Re

Patrick: Le problème avec les images, c'est que si tu ne copies pas le fichier en Gif ou Png, tu n'auras pas d'images incluent dans le fichier mais des liens et si tu l'ouvres sur un autre média, tu ne verras que des carrés avec "image indisponible". De plus le rafraichissement peut être plus ou moins long. Dans ce cas le fichier est très léger. A moins qu'il y ait une option pour intégrer les images en dur dans le fichier?

Ensuite si tu copies, supprimes et fais un collage spécial en Gif par exemple, le fichier sera beaucoup plus voire très lourd mais les images seront insérées dans le fichier et tu peux le déplacer sur un autre média.

Enfin, il existe une bibliothèque Wiiaut.dll qui permet de faire de la vrai compression d'images pour réduire leur poids dans un fichier Excel mais qui est assez complexe à mettre en oeuvre. voir ici:

 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
Patrick: Le problème avec les images, c'est que si tu ne copies pas le fichier en Gif ou Png, tu n'auras pas d'images incluent dans le fichier mais des liens et si tu l'ouvres sur un autre média, tu ne verras que des carrés avec "image indisponible". De plus le rafraichissement peut être plus ou moins long. Dans ce cas le fichier est très léger. A moins qu'il y ait une option pour intégrer les images en dur dans le fichier?
heu .....pouvez récapéter la question
mais qui a bien pu te mettre cette idée en tète ???????????????
 

MJ13

XLDnaute Barbatruc
Excel, tout simplement. :)

Ce qui pourrait donner comme code en utilisant la Windows Acquisition Librairie Wiiaut.dll à cocher dans les références:

VB:
Sub Ins_Image()
For Each cell In Selection
cell.Select
redimensionnerImage
Fichier2 = "C:\Temp\A.JPG"
Set Image = ActiveSheet.Pictures.Insert(Fichier2) '.Select
Image.Copy
 Image.Delete
 ActiveSheet.PasteSpecial Format:="Image (GIF)", Link:=False
Next
End Sub
Sub redimensionnerImage()
    'Dim Img As WIA.ImageFile, IP As WIA.ImageProcess
    Kill "C:\Temp\A.JPG"
    'Création conteneur pour l'image à manipuler
    Set Img = CreateObject("WIA.ImageFile")
    'Création du gestionnaire de filtre
    Set IP = CreateObject("WIA.ImageProcess")
    
    Fichier = Cells(ActiveCell.Row, 1) & "\" & ActiveCell.Value
        'Chargement de l'image dans le conteneur
    'Img.LoadFile "C:\fourmiz.JPG"
    Img.LoadFile Fichier
    
        'Ajoute le filtre pour redimensionner l'image (Scale)
        IP.Filters.Add IP.FilterInfos("Scale").FilterID
        'Définit la largeur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumWidth") = 128
        'Définit la hauteur maxi pour le redimensionnement
        IP.Filters(1).Properties("MaximumHeight") = 128
        'remarque :
        'Les proportions sont conservées. Le filtre prend en compte
        'les ratios et adapte la taille pour ne pas dépasser les valeurs maxi définies.
        
    'Application du filtre à l'image
    Set Img = IP.Apply(Img)
    'Enregistre l'image redimensionnée
    Img.SaveFile "C:\Temp\A.JPG"
    
    
End Sub
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re

je connais très bien WIA
mais dis moi un peu qu'est ce que ça a voir avec l'insertion d'une image dans un sheets et le fait que tu prétends que l'image ne s'enregistre pas dans le fichier après sauvegarde du fichier

que tu me dise que mettre le lien dans une cellule et loader les image a l'ouverture du classeur a fin de ne pas l'alourdir OK

que tu créé un image temp a taille réduite avec wia pour ne pas la garder puisque tu te sert de lien dans activecell.value dis moi un peu a quoi ça sert de te décarcasser a réduire les poids

non la je pige pas ;)
il faut choisir soit un principe soit l'autre
 

MJ13

XLDnaute Barbatruc
Bonjour à tous

Lionel: Fichier intéressant pour avoir un code compact comme Job sait bien le faire. :)

JM: Cela faisait longtemps, heureusement que je suis passé ici et que j'ai vu le code de Patrick qui m' a intrigué. ;)
Pour les "Machistes", c'est pas mon problème, je n'en suis pas un. :D

Patrick: je sais que tu connais très bien le VBA, on s'est déjà croisé ici sur un autre sujet avec la position de la souris sur une feuille il me semble.

Du coup, j'ai remanié ton code sur une appli vieille de 9 ans que Double00 doit se souvenir. :cool:

J'arrive à insérer environ 200 images à la minutes en taille 640 avec un fichier de moins de 10 Mo au final. le but est quand tu as beaucoup de photos réparties dans plusieurs dossiers de pouvoir faire le ménage ou des copies de certains fichiers que tu veux garder ou retraiter.Voici la version 6.
 

Pièces jointes

  • Dir_Mes_Images_XL2016_V6_MJ.xlsm
    62.3 KB · Affichages: 15
Dernière édition:

Discussions similaires