XL 2019 Insérer plusieurs images dans plusieurs cellules en suivant un ordre précis

[cedric123]

Bonjour a tous,

Je suis un novice sur Visual basic,
En fouillant un peut sur le net j'ai réussi a trouver une macro qui correspond a 80% a mes besoins,
Elle me permet en effet, comme le titre de la discussion l'indique d'insérer une ou plusieurs images dans plusieurs cellules en les redimensionnant automatiquement a la taille de la cellule,
L'ordre d'insertion des images est défini par l'ordre dans lequel je sélectionne les cellules au départ :

- Je sélectionne A1 puis A2 (ctrl + click)
- j'exécute la macro
- la fenêtre d'insertion d'image s'ouvre et je sélectionne la Photo1 et Photo2
- Lors de l'insertion la Photo1 vient se loger en cellule A1 e la Photo2 en cellule A2

Si au départ j'avais sélectionné la cellule A2 en premier et ensuite A1 la Photo1 se serait logé en A2 et la Photo2 en A1 ...

Mon souhait serait de pouvoir adapter mon code de sorte que l'ordre d'insertion des image se fasse au moment de la sélection des photos et non des cellules :

- Je sélectionne A1 puis A2
- j'exécute la macro mais si je sélectionne la Photo2 en premier et ensuite la Photo1, la Photo2 viendra se loger en cellule A1 et la Photo1 en cellule A2

Voici le code de la macro en question :

Public Sub insere_image()
Dim ficimg, nbImg As Byte
Dim Cel As Range, Plage As Range

On Error Resume Next
ficimg = Application.GetOpenFilename(".jpeg,*.jpeg", , "Choisissez l'image", , True) ' choix nom du fichier
Set Plage = Selection
For Each Cel In Plage
Cel.Select
nbImg = nbImg + 1
If Not ficimg(nbImg) = "" Then
ActiveSheet.Pictures.Insert(ficimg(nbImg)).Select ' insertion
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = ActiveCell.Top ' haut de la cellule
.Left = ActiveCell.Left ' gauche de la cellule
.Height = ActiveCell.RowHeight ' hauteur de la cellule
.Width = ActiveCell.Width ' largeur de la cellule
End With
Selection.Placement = xlMoveAndSize
End If
Next
End Sub

Je remercie par avance tous ceux qui auront l'amabilité de me répondre,

Cordialement,

Cédric

 

[cedric123]

Re,

Je pensais que tu parlais du code que j'utilisait au début,

Voila la capture d'écran de ton code :

Tu peux voir en PJ le rendu que cela donne chez moi :

 

[Staple1600]

Re

J'ai édité mon code
En mettant :.LockAspectRatio = msoFalse

Corrige et refais le test.

 

[Staple1600]

Re

Essaies sur un fichier vierge, en testant uniquement avec 3 cellules sélectionnées et trois images sélectionnées.

 

[cedric123]

Re,

Le code corrigé :

Le rendu n'est toujours pas bon chez moi contrairement a toi :

 

[Staple1600]

Re

Enregitres ton classeur en *.xlsb ou *.xlsm
(je parle du classeur vierge pour faire le test)

Et essaie avec une seule cellule et une seule image.

 

[cedric123]

Re

Enregitres ton classeur en *.xlsb ou *.xlsm
(je parle du classeur vierge pour faire le test)

Et essaie avec une seule cellule et une seule image.

Re,

Le rendu est le même j'ai essayé avec les deux .xlsb et xlsm,
L'image s'insère plusieurs lignes plus bas et pas a l'échelle de la cellule sélectionnée,
Tu penses que c'est du au fait que l'on utilise une version différente d'Excel ?

ue

 

[Staple1600]

Re

Justement, j'allais y venir
Peux-tu insérer manuellement une image tout en laissant tourner l'enregistreur de macros pour voir si le code VBA obtenu est le même qu'avec ma version Excel.

 

[cedric123]

Re,

Oui j'ai sélectionné une cellule et inséré une image et voila le code obtenu ( je n'ai pas redimensionné l'image mais l'ai laissé tel quel )

Le rendu :

 

[cedric123]

Re,

La macro obtenue avec la selection de la cellule :

 

[Staple1600]

Re

Et que donne cette autre version de test?

Sub Macro1()
Dim imgPath, r As Range
imgPath = "C:\Users\STAPLE\Pictures\TESTS\img01.png" '<- à adapter
Set r = ActiveCell
ActiveSheet.Pictures.Insert(imgPath).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Left = r.Left
Selection.ShapeRange.Top = r.Top
Selection.ShapeRange.Width = r.Width
Selection.ShapeRange.Height = r.Height
End Sub

 

[cedric123]

Re,

Impossible de lancer la macro, un code d'erreur 400 s'affiche :

 

[Staple1600]

Re

Tu n'as pas fait l'adaptation comme indiqué dans le commentaire en vert.
Il faut mettre un chemin et un nom d'image qui existe sur ton disque dur.

La même macro (mais sans les Select)

Sub Macro2()
Dim imgPath, r As Range, img As Picture
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
imgPath = "C:\Users\STAPLE\Pictures\TESTS\img01.png" '<====== A ADAPTER +
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set r = ActiveCell
Set img = ActiveSheet.Pictures.Insert(imgPath)
With img.ShapeRange
    .LockAspectRatio = msoFalse
    .Left = r.Left: .Top = r.Top
    .Width = r.Width: .Height = r.Height
End With
End Sub

 

[cedric123]

Re,

Autant pour moi ca fonctionne en mettant le chemin de l'image, elle remplit bien la taille de la cellule :

 

[Staple1600]

Re

Donc ce n'est pas une question de version

Comment tu sélectionnais les cellules précédemment
(quelles combinaisons de touche)
Et les images comment tu les sélectionnes?

 

[cedric123]

Re,

Je sélectionne toujours les cellules avec CTRL + click
Idem pour les images,