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 vba : Sélectionner tout - Visualiser dans une fenêtre à part
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"