Code VBA pour importer une image sans lien

Version imprimable

Bonjour à tous,

J'avais réalisé un petit code VBA pour importer une image et la dimensionner à la taille d'une cellule. Tout a très fonctionné jusqu'à que je passe à Office 2019 (avant j'étais sur office 2007). Maintenant, mon code ne "colle" plus l'image mais conserve un lien. Du coup, si je déplace ou supprime l'image de mon PC alors l'image disparait également de mon classeur.

J'ai chercher longtemps sur internet mais je n'ai pas trouvé de réponse à mon problème.

Merci d'avance pour votre aide !!!

Frederic

Voici mon code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub AjoutImage() 'ajouter image
Dim ficimg As String, Ad As String, ImageName As String
Dim CellH As Long, CellW As Long
Dim ShapeObj As Object
 
    ActiveSheet.Range("CellImage").Select
    Ad = Selection.Address
    CellH = Selection.Height
    CellW = Selection.Width
    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix de l'image
    If ficimg = "Faux" Then ActiveSheet.Protect Password:="xxxxx", DrawingObjects:=False, Contents:=True, AllowFormattingCells:=True: Exit Sub
    ActiveSheet.Pictures.Insert(ficimg).Select ' insertion de l'image
    With Selection.ShapeRange
      ImageName = ActiveSheet.Name
      .Name = ImageName
      .LockAspectRatio = False ' ne conserve pas la proportions d'origine
      .Top = Range(Ad).Top + 0.5 ' haut de la cellule
      .Left = Range(Ad).Left + 0.5 ' gauche de la cellule
      .Height = CellH - 0.5
      .Width = CellW - 0.5
      .SoftEdge.Type = msoSoftEdgeType4
    End With
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With
    Application.SendKeys "AC~", True
    Application.CommandBars.ExecuteMso "PicturesCompress"

30/07/2020, 20h17
marot_r

Bonjour.

Apparemment tu n'es pas seul.

Ici une solution selon l'auteur.

VBA Insert Picture Bug
https://www.mrexcel.com/excel-tips/v...t-picture-bug/

A+
31/07/2020, 08h30
Menhir
Une petite remarque liminaire : je te déconseille l'utilisation de Select qui sont toujours ambigus.
Il est préférable de passer par des variables objets pour désigner ton image, en récupérant sa référence par la valeur renvoyée par la méthode qui sert à les insérer.

Ca concerne aussi la cellule destination.
Tu devrais remplacer
Code:

1 2 3 4 5 6 Dim Ad As String ActiveSheet.Range("CellImage").Select Ad = Selection.Address CellH = Selection.Height CellW = Selection.Width
par
Code:

1 2 3 4 Dim Ad As Range Set Ad =ActiveSheet.Range("CellImage") CellH = Ad.Height CellW = Ad.Width
Pour ce qui est du chargement de ton image, essaye ça :
Code:

1 2 Dim MonImage As Shape Set MonImage = ActiveSheet.Shapes.AddPicture ficimg, False, True, Ad.Top, Ad.Left, Ad.Height, Ad.Widht
Ce code remplace aussi une partie de ce qui se trouve dans le With en dessous.

Lire ça : https://docs.microsoft.com/fr-fr/off...ectedfrom=MSDN
03/08/2020, 09h13
FredW

Merci !!!

Merci Marot_r, merci Menhir, vos remarques m'ont été d'une grand aide, j'ai pu résoudre mon problème grâce à vous.