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

Pièces jointes

  • test rj13.zip
    592.9 KB · Affichages: 17

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

Statistiques des forums

Discussions
311 725
Messages
2 081 939
Membres
101 844
dernier inscrit
pktla