XL 2016 Importation de photos

[auverland]

Bonjour à tous

J'ai récupérer une super petite macro qui permet d'importer des photos dans une feuille. Cela fonctionne super bien mais le Hic c'est que dès que je déplace mon fichier de répertoire ou dès que je le transfert sur un autre ordinateur mes photos sont en faite que des liens qui fonctionne plus....

J'arrive pas à trouver la commande qui intègre complètement l'image dans la feuille et non juste le lien....

Merci d'avance pour votre aide sur le sujet

 

[MJ13]

Bonjour Auverland,

Tu peux modifier ce code (j'ai rajouté le cut et le paste special jpeg).

Private Sub CommandButton3_Click()
' coller l'image dans la plage de cellule
' en conservant les proportions de l'image
Dim shp, Lplage, HPlage, Lshp, Hshp, r1, r2, r

On Error GoTo ERR_002
  Application.ScreenUpdating = False
  Application.Goto Plage, False
  'charger le fichier image
  Set shp = ActiveSheet.Pictures.insert(Fichier)
  'dimensions de la plage
  Lplage = Cells(Plage.Row, Plage.Column + Plage.Columns.Count).Left - Plage.Left
  HPlage = Cells(Plage.Row + Plage.Rows.Count, Plage.Column).Top - Plage.Top
  With shp
    ' maintien du ration de l'image
    .ShapeRange.LockAspectRatio = msoTrue
    ' dimension de l'image
    Lshp = .Width: Hshp = .Height
    ' quelle coefficient appliquer pour re-dimensionner l'image
    r1 = Lplage / Lshp: r2 = HPlage / Hshp
    If r1 < r2 Then r = r1 Else r = r2
    ' re-dimensiopnner l'image
    .Width = r * .Width
    ' placer l'image au coin supérieur gauche de la plage
    .Top = Plage.Top: .Left = Plage.Left
  
    ' applique une bordure
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Line.Visible = True
    .ShapeRange.Line.ForeColor.RGB = RGB(100, 100, 100)
    .ShapeRange.Line.Weight = 1
    .Width = .Width - 2: .Height = .Height - 2
    .Top = .Top + 1.5
    .Left = .Left + 1.5
  End With
  shp.Select
  Selection.Cut
  ActiveSheet.PasteSpecial Format:="Image (jpeg)", Link:=False, DisplayAsIcon _
        :=False
  Application.ScreenUpdating = True
  Exit Sub

ERR_002:
  MsgBox "Erreur ! Yé souis décholé..."
End Sub