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

 

[Staple1600]

Bonjour

A tester
NB: Inutile de sélectionner les cellules

Sub Main()
Dim fd As FileDialog, i&
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
If .Show = -1 Then
If .SelectedItems.Count > 2 Then Exit Sub
i = 1
For Each vrtSelectedItem In .SelectedItems
insérerIMG vrtSelectedItem, i
i = i + 1
Next
'If the user presses Cancel...
Else
End If
End With
Set fd = Nothing
End Sub
Private Function insérerIMG(strPath, i)
Dim rng As Range
Set rng = ActiveSheet.Range("A" & i)
With ActiveSheet.Pictures.insert(strPath)
    With .ShapeRange
    .LockAspectRatio = msoTrue: .Width = rng.Width: .Height = rng.Height
    End With
    .Left = rng.Left: .Top = rng.Top: .Placement = xlMoveAndSize
End With
End Function

NB: Le code pour la boite de dialogue vient de la Maison mère

 

[cedric123]

Bonjour,

Tout d'abord merci beaucoup pour la réponse
Chose que j'aurai surement du préciser, je citait les cellules A1 et A2 en exemple cependant dans la réalité je dois avoir la liberté de sélectionner n'importe quelle cellule de mon choix,
En ce sens le code qui figurait dans mon premier message fait très bien le taf sur ce point,
deuxièmement après avoir essayé votre code, les photos ne s'insèrent pas dans l'ordre ou je les sélectionnent juste avant de les insérer,
Les photos s'insèrent en A1 et A2 dans le même ordre qu'elles apparaissent dans leur fichier, hors j'aimerai pouvoir si besoin, insérer la dernière photo du fichier avant la première ( a titre d'exemple ) et qu'elles s'insèrent dans les cellules que j'ai sélectionnées au préalable dans le même ordre que je les ai sélectionnées dans la boite de dialogue,

L'idéal serait de pouvoir ajouter au premier code la solution pour qu'il prènent en compte l'ordre de selection des photos dans la boite de dialogue

Cordialment

Cédric

 

[Staple1600]

Re

Et avec ces modifications?
(chez moi cela fonctionne)

Sub Main()
Dim fd As FileDialog, i&
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
If .Show = -1 Then
i = 1
For Each vrtSelectedItem In .SelectedItems
insérerIMG vrtSelectedItem, i
i = i + 1
Next
'If the user presses Cancel...
Else
End If
End With
Set fd = Nothing
End Sub
Private Function insérerIMG(strPath, i)
Dim rng As Range
Set rng = ActiveCell.Offset(i, 0)
With ActiveSheet.Pictures.insert(strPath)
    With .ShapeRange
    .LockAspectRatio = msoTrue: .Width = rng.Width: .Height = rng.Height
    End With
    .Left = rng.Left: .Top = rng.Top: .Placement = xlMoveAndSize
End With
End Function

 

[cedric123]

Re,

Les images viennent se loger sous la dernière cellule sélectionnée et toujours dans le même ordre quel que soit l'ordre de sélection dans la boite de dialogue,

J'ai sélectionné B5 D5 et F5 j'ai exécuté la macro et sélectionné 3 images mais elles se sont logées en F6 F7 et F8,

Cordialement

Cédric

 

[Staple1600]

Re

Avec le code tel que rédigé
Pour tester il faut sélectionner une cellule unique
et les images se mettent dans les cellules en dessous de cette 1ère cellule sélectionnée.

 

[Staple1600]

Re

Comme ceci, on se rapproche
(mais il y aura des effets de bord)

Sub Main()
Dim fd As FileDialog, adres, x$, i&
adres = Split(Selection.Address, ",")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
If .Show = -1 Then
i = 0
On Error Resume Next
For Each vrtSelectedItem In .SelectedItems
x = adres(i)
insérerIMG x, vrtSelectedItem, i
i = i + 1
Next
'If the user presses Cancel...
Else
End If
End With
Set fd = Nothing
End Sub
Private Function insérerIMG(adr$, strPath, i)
Dim rng As Range
Set rng = Range(adr)
With ActiveSheet.Pictures.insert(strPath)
    With .ShapeRange
    .LockAspectRatio = msoFalse: .Width = rng.Width: .Height = rng.Height
    .Left = rng.Left: .Top = rng.Top: .Placement = xlMoveAndSize
    End With
End With
End Function

 

[cedric123]

Re,

Merci encore pour votre aide,
C'est en effet le résultat que j'ai lorsque j'exécute cette macro
Pour mieux vous situer mon problème je dois insérer des images dans des cellules qui ne sont pas forcément voisines les unes des autres,

Voyez le document que je dois remplir, ici les cases B5 D5 et F5 doivent êtres occupées par des images bien précises,
A ce titre le code que j'ai communiqué dans mon premier message est très efficace, son seul défaut est qu'il ne prend pas en compte l'ordre de sélections des photos dans la boite de dialogue et que les images s'insèrent dans l'ordre ou elles figurent dans leur fichier, seulement il se peut que la dernière image du dossier doit être placée dans la première cellule ( B5 ) et que la première image du dossier aille dans la dernière cellule ( F5 )

Si seulement je pouvait trouver la ou les lignes de codes qui gèrent l'ordre d'insertion des images en fonction de l'ordre de sélection des images dans la boite de dialogue tout en l'adaptant au premier code qui remplis le reste de mes besoins se serait parfait !

Cordialement,

Cédric

 

[cedric123]

Re

Comme ceci, on se rapproche
(mais il y aura des effets de bord)

Sub Main()
Dim fd As FileDialog, adres, x$, i&
adres = Split(Selection.Address, ",")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
If .Show = -1 Then
i = 0
On Error Resume Next
For Each vrtSelectedItem In .SelectedItems
x = adres(i)
insérerIMG x, vrtSelectedItem, i
i = i + 1
Next
'If the user presses Cancel...
Else
End If
End With
Set fd = Nothing
End Sub
Private Function insérerIMG(adr$, strPath, i)
Dim rng As Range
Set rng = Range(adr)
With ActiveSheet.Pictures.insert(strPath)
    With .ShapeRange
    .LockAspectRatio = msoTrue: .Width = rng.Width: .Height = rng.Height
    End With
    .Left = rng.Left: .Top = rng.Top: .Placement = xlMoveAndSize
End With
End Function

Je viens d'essayer le code,

Est-ce normal que les photos ne s'insèrent pas dans les cellules selectionnées mais deux cases plus bas ?

 

[Staple1600]

Re

J'ai testé en sélectionnant A1, C4 et F5
Et les images sont insérées en A1, C4 et F5
(testé sur Excel 2013)
(avec le dernier code fourni*)
(donc les dernières versions de Main et la fonction insérerIMG )

 

[cedric123]

Re,

Je ne sais pas pourquoi cela ne marche pas comme prévu chez moi..
Ne vous embêtez pas plus que ca,
Merci beaucoup pour votre aide

Cordialement,

Cédric

 

[Staple1600]

Re

Je ne m'embête pas sinon pourquoi prendrais-je le temps de titiller mon VBA dans Excel?

Tu peux poster une copie d'écran du code VBA que tu utilises, stp?
(celle qui s'affiche dans ton VBE)

 

[cedric123]

Re,

Pas de problème, voila la capture d'écran du code :

 

[Staple1600]

Re

???
Et où est donc le code VBA que je t'ai proposé!

 

[Staple1600]

Re

Donc en guise de preuve de fonctionnement du code que j'ai proposé