XL 2013 Image dans shape

Noopy123 · 27 Avril 2020

Bonjour,

Est-il possible d'ajouter une image dans une shape sélectionnée ?
J'ai un fichier qui créé un nombre aléatoire de rectangle et j'aimerais mettre une image en fond dans les rectangles que j'ai préalablement sélectionné. Le top serait de le faire via un double clique sur la cellule sélectionnée 🙂

Merci par avance

Staple1600 · 27 Avril 2020

Bonjour job75

•>Noop123
J'ai complété mon test
(toujours sur une feuille vierge, et cette fois-ci, tu peux lancer plusieurs fois de suite la macro PreTest_II)
test OK sur Excel 2013
(La mise en forme de la shape "test" est appliquée sur les 4 formes à droite de celle-ci quand on clique sur une de ces 4 formes)

VB:

Sub PreTest_II()
Dim shp As Shape, c As Range, p As Range, x As Range, i%, vShps()
Set c = [C2]: c.RowHeight = 100: Set p = c.Offset(, 2): Randomize 1600
With ActiveSheet
.DrawingObjects.Delete
Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height)
y = Application.RandBetween(0, 8)
shp.Fill.PresetTextured Array(4, 10, 5, 22, 16, 8, 14, 19, 18)(y)
shp.Name = "test": vShps = Array(3, 15, 14, 23)
For i = 0 To 3
Set x = p(1, (i + 1) * 2)
Set shp = .Shapes.AddShape(vShps(i), x.Left, x.Top, x.Width, x.Height)
shp.Fill.ForeColor.SchemeColor = vShps(i)
shp.OnAction = "Test_II"
Next
End With
End Sub

Sub Test_II()
With ActiveSheet
 .Shapes("test").PickUp
 .Shapes(Application.Caller).Apply
End With
End Sub

Noopy123 · 27 Avril 2020

Staple1600 à dit:
Tu as testé sur une feuille vierge?
Tu as bien mis le code dans un module standard?

Oui j'ai bien suivi le mode d'emploi mais bizarrement j'ai essayé pas mal de technique avec le application.caller et a chaque fois j'ai un message d'erreur :/

Staple1600 · 27 Avril 2020

Re

Le mode opératoire est le suivant
1) Dans un classeur vierge, tu inséres un module standard dans lequel tu copies/colles le code du message#16
2) Tu lances la macro PreTest_II
Puis tu cliques sur une des 4 formes à droite de "test"
Ça doit fonctionner.
(Le préfixe de ta discussion indique XL 2013, or je suis aussi sur XL 2013)

Noopy123 · 27 Avril 2020

Staple1600 à dit:
Bonjour job75

•>Noop123
J'ai complété mon test
(toujours sur une feuille vierge, et cette fois-ci, tu peux lancer plusieurs fois de suite la macro PreTest_II)
test OK sur Excel 2013
(La mise en forme de la shape "test" est appliquée sur les 4 formes à droite de celle-ci quand on clique sur une de ces 4 formes)

VB:

Sub PreTest_II() Dim shp As Shape, c As Range, p As Range, x As Range, i%, vShps() Set c = [C2]: c.RowHeight = 100: Set p = c.Offset(, 2): Randomize 1600 With ActiveSheet .DrawingObjects.Delete Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height) y = Application.RandBetween(0, 8) shp.Fill.PresetTextured Array(4, 10, 5, 22, 16, 8, 14, 19, 18)(y) shp.Name = "test": vShps = Array(3, 15, 14, 23) For i = 0 To 3 Set x = p(1, (i + 1) * 2) Set shp = .Shapes.AddShape(vShps(i), x.Left, x.Top, x.Width, x.Height) shp.Fill.ForeColor.SchemeColor = vShps(i) shp.OnAction = "Test_II" Next End With End Sub Sub Test_II() With ActiveSheet .Shapes("test").PickUp .Shapes(Application.Caller).Apply End With End Sub

Je viens d'essayer et encore le même message d'erreur 😳😵

Staple1600 · 27 Avril 2020

Re

Pourtant cela fonctionne, la preuve 😉

job75 · 27 Avril 2020

Un je-m'en-foutiste ou un nul ?

job75 à dit:
Voyez le fichier joint et cliquez sur la Shape que vous voulez traiter dans la 1ère feuille.

Staple1600 · 28 Avril 2020

Bonjour le fil, Noopy123, job75

Avec ceci, si la sélection de shapes est multiple, le changement de format s'applique sur toutes les formes sélectionnées
(Rappel: dans cet exemple, la texture présente sur "test" remplace une image, mais le résultat est le même si "test" contient une image)
le mode opératoire pour tester est différent
1) Lancer PreTest_III
Puis sélectionner une ou plusieurs shapes (autre que celle nommée "test")
et lancer ensuite (à partir de VBE) la macro Test_III

Code:

Sub PreTest_III()
Dim shp As Shape, c As Range, p As Range, x As Range, i%, vShps()
Set c = [C2]: c.RowHeight = 100: Set p = c.Offset(, 2): Randomize 1600
With ActiveSheet
.DrawingObjects.Delete
Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height)
y = Application.RandBetween(0, 8)
shp.Fill.PresetTextured Array(4, 10, 5, 22, 16, 8, 14, 19, 18)(y)
shp.Name = "test": vShps = Array(3, 15, 14, 23)
For i = 0 To 3
Set x = p(1, (i + 1) * 2)
Set shp = .Shapes.AddShape(vShps(i), x.Left, x.Top, x.Width, x.Height)
shp.Fill.ForeColor.SchemeColor = vShps(i)
Next
End With
End Sub

Sub Test_III()
'Dans cette version, le changement s'appliquera sur les shapes sélectionnées
'soit une seule, soit sélection multiple
Dim shp As Shape
With ActiveSheet
 .Shapes("test").PickUp
    For Each shp In ActiveWindow.Selection.ShapeRange
    shp.Apply
    Next
End With
End Sub

PS: job75
Bienvenue au club des XLDdiens ostracisés ou parfois invisibles...
C'est vrai que ce n'est pas agréable (j'en sais quelque chose) 😉

Noopy123 · 28 Avril 2020

Staple1600 à dit:
Re

Pourtant cela fonctionne, la preuve 😉
Regarde la pièce jointe 1064507

Bonjour Staple1600,

C'est bon ça marche bien. Je ne sais pas ce que j'ai fais comme bêtise hier soir mais en tout cas c'est bon ça marche nickel

Noopy123 · 28 Avril 2020

job75 à dit:
Un je-m'en-foutiste ou un nul ?

Bonjour job75
Désolé de ne pas avoir répondu immediatement, j'essaie de bien comprendre le code avant de l'utiliser et de donner mes impressions 😉, je suis encore en phase de transcription^^

Noopy123 · 28 Avril 2020

Staple1600 à dit:
Bonjour le fil, Noopy123, job75

Avec ceci, si la sélection de shapes est multiple, le changement de format s'applique sur toutes les formes sélectionnées
(Rappel: dans cet exemple, la texture présente sur "test" remplace une image, mais le résultat est le même si "test" contient une image)
le mode opératoire pour tester est différent
1) Lancer PreTest_III
Puis sélectionner une ou plusieurs shapes (autre que celle nommée "test")
et lancer ensuite (à partir de VBE) la macro Test_III

Code:

Sub PreTest_III() Dim shp As Shape, c As Range, p As Range, x As Range, i%, vShps() Set c = [C2]: c.RowHeight = 100: Set p = c.Offset(, 2): Randomize 1600 With ActiveSheet .DrawingObjects.Delete Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height) y = Application.RandBetween(0, 8) shp.Fill.PresetTextured Array(4, 10, 5, 22, 16, 8, 14, 19, 18)(y) shp.Name = "test": vShps = Array(3, 15, 14, 23) For i = 0 To 3 Set x = p(1, (i + 1) * 2) Set shp = .Shapes.AddShape(vShps(i), x.Left, x.Top, x.Width, x.Height) shp.Fill.ForeColor.SchemeColor = vShps(i) Next End With End Sub Sub Test_III() 'Dans cette version, le changement s'appliquera sur les shapes sélectionnées 'soit une seule, soit sélection multiple Dim shp As Shape With ActiveSheet .Shapes("test").PickUp For Each shp In ActiveWindow.Selection.ShapeRange shp.Apply Next End With End Sub

PS: job75
Bienvenue au club des XLDdiens ostracisés ou parfois invisibles...
C'est vrai que ce n'est pas agréable (j'en sais quelque chose) 😉

Je viens d'essayer ce code mais rien ne se passe. J'ai mis Test_III dans un commandButton pour declancher la copie mais rien non plus. Sais-tu où est mon erreur ?

Staple1600 · 28 Avril 2020

Re

•>Noopy123
Je n'ai pas parlé de CommandButton...🙄
(Relire mon précédent message)

Noopy123 · 28 Avril 2020

Staple1600 à dit:
Re

•>Noopy123
Je n'ai pas parlé de CommandButton...🙄
(Relire mon précédent message)

Oui j'ai testé le avec et le sans command button mais pas de changement des formes

Staple1600 · 28 Avril 2020

Re

Si, il y a changement sinon pourquoi aurais-je posté ce nouveau code?
🙄
Relire attentivement le mode opératoire du message#22
(et faire exactement tout ce qu'on y lit)

NB: Je te rappelle qu'hier tu disais que cela ne fonctionnait pas
puis O surprise, ce matin, tu écris

C'est bon ça marche bien. Je ne sais pas ce que j'ai fais comme bêtise hier soir mais en tout cas c'est bon ça marche nickel

😉

Noopy123 · 28 Avril 2020

Finalement, j'ai trouvé un truc hyper simple qui pour l'instant marche :
J'ai crée un Bouton et je lui ai affecté cette macro et ma photo se met bien en arrière plan de mes formes séléctionnées

VB:

Sub Bouton2_Cliquer()
Selection.ShapeRange.Fill.UserPicture "C:\Users\utilisateur\Desktop\PHOTO \3.jpg"
End Sub

Par contre via ce code, si pas de cellule séléctionné ça plante. Est-il possible d'avoir un msg box si aucune shape séléctionnées et faire un exit sub ?

job75 · 28 Avril 2020

Bonjour Noopy123, JM,

Noopy123 à dit:
En fait l'utilisateur choisira parmi différentes images celle qu'il veut mettre dans la forme

Votre dernière solution ne choisit pas...

A+

XL 2013 Image dans shape

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Noopy123

XLDnaute Junior

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

job75

XLDnaute Barbatruc

Discussions similaires

XL 2013 Image dans shape

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency