Microsoft 365 Macro Insertion image dans cellule

l.et.lilou · 12 Janvier 2024

Bonjour à tous,

J'ai besoin de votre aide (de nouveau haha).
Je pense que la macro est simple mais je n'y arrive pas...

Je vous joins mon fichier pour que ca soit plus claire mais j'aimerais simplement :
- Supprimer la précédente image ajoutée dans la cellule
- Ajouter la nouvelle image dans la cellule.

1) Ma première difficulté c'est que je suis obligée de placer l'image dans la cellule pour pouvoir grouper mes lignes avec l'image comprise
2) Ma deuxième difficulté c'est que l'image devient flou ou mal ajustée selon ses dimensions - pensez vous que c'est possible de la faire ajuster automatiquement ?

Je vous envoi mon fichier avec un test d'image...
Ma macro est dedans, je vous la joins ici aussi :

Sub AjouterImage()
Dim cheminImage As String
Dim img As Shape
Set img = ActiveSheet.Shapes(cheminImage)
Dim celluleCible As Range
Set celluleCible = ActiveSheet.Range("P236")

Range("P236").Select
Selection.ClearContents

cheminImage = Application.GetOpenFilename(FileFilter:="Images (*.jpg; *.jpeg; *.png; *.gif), *.jpg; *.jpeg; *.png; *.gif")

If cheminImage <> "Faux" Then
ActiveSheet.Pictures.Insert(cheminImage).Select
With img
.LockAspectRatio = msoFalse
.Width = celluleCible.Width
.Height = celluleCible.Height
.Top = celluleCible.Top
.Left = celluleCible.Left
End With
End If
End Sub

Merci de votre aide

Dranreb · 12 Janvier 2024

Bonjour.
Je trouve qu'on a moins de problème de fidélité et de manipulation avec une Image ActiveX. Par contre on n'a pas les .png.

l.et.lilou · 14 Janvier 2024

je ne connais pas du tout. Je vais regarder alors si c'est une nouvelle piste

Dranreb · 14 Janvier 2024

Bonjour.
Exemple de code, alors :

VB:

Option Explicit
Sub AjouterImage()
   Dim CheminImage, Img As MSForms.Image, OOt As OLEObject, Rng As Range
   On Error Resume Next
   CheminImage = Application.GetOpenFilename(FileFilter:="Images (*.jpg; *.jpeg; *.gif), *.jpg; *.jpeg; *.gif")
   If VarType(CheminImage) <> vbString Then Exit Sub
   Set OOt = ActiveSheet.OLEObjects("Image")
   If Err Then
      Set Rng = ActiveSheet.Range("P236").MergeArea
      Set OOt = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
        DisplayAsIcon:=False, Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Width, Height:=Rng.Width)
      OOt.Name = "Image"
      End If
   Set Img = OOt.Object
   Img.PictureSizeMode = fmPictureSizeModeZoom
   Img.Picture = LoadPicture(CheminImage)
   End Sub

Microsoft 365 Macro Insertion image dans cellule

l.et.lilou

XLDnaute Junior

Pièces jointes

Dranreb

XLDnaute Barbatruc

l.et.lilou

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Discussions similaires