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 Impliqué
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
 

Marcodon

XLDnaute Nouveau
Merci mille fois patricktoulon pour votre obligeance.
À charge de revanche s'il m'est possible.
Bien à Vous.
 

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.
 

Marcodon

XLDnaute Nouveau
Tout à fait d'accord MJ13 !

D'ailleurs mon enthousiasme premier s'est vite dissipé lorsque j'ai voulu intégrer le code de patricktoulon à ma macro.
Ça ne "marche" pas du tout.

So, wait and see !

Bien sincèrement.
 

patricktoulon

XLDnaute Impliqué
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 Impliqué
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 Impliqué
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 Impliqué
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
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

Ce qui pourrait donner comme code en utilisant la Windows Acquisition Librairie Wiiaut.dll à cocher dans les références:
Ne fonctionnera pas pour les MACistes.
(Ils sont encore nombreux ;))

PS: Eh les gars, Excel c'est un tableur à la base, pas ce genre de joujou, non ? ;)
 

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.
 

Fichiers joints

Dernière édition:

patricktoulon

XLDnaute Impliqué
bonjour mj13
j'ai très bien compris tes intentions
mais je te le redis
200 photos ou image de 640X....
perso je met les liens dans le range de destination(emplacement de l'image)
je vire TOUT!!! code
et avec une seule boucle je load les images a l'ouverture du fichier ou a l'activate d'un sheets
et je VIRE!!! WIA
TOTAL mon fichier ne pèze que quelques kilo ,pas de temps de démarrage,pas de lenteur ,etc...

et rien empêche de changer les liens dans les cellules

j'avais même a l’époque trouvé une autre solution encore plus rapide
c'est l'utilisation d'un webdocument dynamique dans un webbrowser adapté a la taille des cellules
mais c'est un autre débat
je ne la montrerais pas car le webbrowser est sujet a soucis pour les non avertis sur les version sup a 2007
 

MJ13

XLDnaute Barbatruc
Re

mais je te le redis
200 photos ou image de 640X....
perso je met les liens dans le range de destination(emplacement de l'image)
je vire TOUT!!! code
et avec une seule boucle je load les images a l'ouverture du fichier ou a l'activate d'un sheets
et je VIRE!!! WIA
TOTAL mon fichier ne pèze que quelques kilo ,pas de temps de démarrage,pas de lenteur ,etc...
Patrick: Merci pour cette réponse, mais si tu pouvais m'expliquer comment tu fais, cela pourrait m'intéresser.

Bon Week-End :)
 

patricktoulon

XLDnaute Impliqué
re
bonjour MJ13
dézip
ouvre le xl
lance reload link
et lance put_all_image
terminé
ta liste est a jours en fonction du dossier
tes images(toutes) sont centrée dans la cellules de destination
avant de fermer tu relance reload link et tu sauve
ton fichier ne contient donc aucunes images
il pèze donc 3 cacahuètes
j'ai fait ça vite fait avec ce que j'avais sous la main des".ico" j'en ai toute une collection ;)
terminé
 

Fichiers joints

MJ13

XLDnaute Barbatruc
Re

Merci beaucoup Patrick, cela m'a l'air intéresssant comme démarche, je vais étudier ça la semaine prochaine. :)
 

MJ13

XLDnaute Barbatruc
Bonjour à tous

Patrick: J'ai testé ton programme , surtout la partie Put_All_Images. Cela fonctionne bien tant qu'on a pas plus de 500 images, après on a plus de ralentissements, surtout à l'ouverture du fichier et dès qu'on veut modifier, par exemple, une largeur de colonne.

Mais je le garde,dans le cas, comme souvent, où j'ai moins de 500 photos à traiter. :)

Encore merci. ;)

VB:
Sub Ins_All_Images_PT()
Timer1 = Timer
    Dim img As Picture, cel As Range
   Application.ScreenUpdating = False
   With ActiveSheet 'Sheets(1)
        For Each cel In .Range("C2", Cells(Rows.Count, "C").End(xlUp))
           If Not IsEmpty(cel) Then
                Set img = .Pictures.Insert(cel.Offset(0, -1) & "\" & cel.Value)
                'place_l_image_dans cel.Offset(, 1), img, 4
                place_l_image_dans cel.Offset(0, 0), img, 4
            End If
        Next
    End With
Application.ScreenUpdating = True
MsgBox Timer - Timer1
End Sub

'sub de placement et centrage de l'image  dans la range en parametre tout en respectant son  ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
    Dim ratio#, W#, H#
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ' calcul ratio
        ratio = .Width / .Height    'ratio shape ou picture
        W = Rng.Width       ' width  range
        H = Rng.Height      ' height range
        If (W / H < ratio) Then    'comparaison ratio range/image
            .Width = W - space    'en redimentionant le width le height se redimentionne automatiquement
        Else    'ou
            .Height = H - (space / ratio)    'en redimentionant le height le width se redimentionne automatiquement
        End If
        .Left = Rng.Left + ((Rng.Width - .Width) / 2)    'adaptation du left en fonction de la dimention width du shape
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)    'adaptation du top en fonction de la dimention height du shape
        .Placement = 1
    End With
End Sub
 
Dernière édition:

Discussions similaires


Haut Bas