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

cedric123

XLDnaute Nouveau
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

XLDnaute Nouveau
Re,

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

Voila la capture d'écran de ton code :

Capture.PNG



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

Pièces jointes

  • etape 1.PNG
    etape 1.PNG
    249 KB · Affichages: 46
  • etape 2.PNG
    etape 2.PNG
    170.9 KB · Affichages: 38

cedric123

XLDnaute Nouveau
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 ?
Capture3.PNG
ue
 

Staple1600

XLDnaute Barbatruc
Re

Et que donne cette autre version de test?
VB:
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
 

Staple1600

XLDnaute Barbatruc
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)
VB:
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
 

Discussions similaires