Microsoft 365 Afficher une image, présente dans l'ordinateur, à partir d'un chemin d'accès

Sub essai()
  répertoirePhoto = "c:\mesdoc\" ' Adapter
  nom = "droc"
  ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg").Name = nom
  ActiveSheet.Shapes(nom).Left = [B2].Left
  ActiveSheet.Shapes(nom).Top = [B2].Top
End Sub

Sub ImportImage()
  Image = Application.GetOpenFilename("Fichiers Gif ou Jpg ,*.gif;*.jpg")
  If Image <> False Then
    a = Split(Image, "\")
    nomimage = a(UBound(a))
    Set c = ActiveCell
    With ActiveSheet
     .Pictures.Insert(Image).Name = nomimage
     .Shapes(nomimage).Height = c.Height
     .Shapes(nomimage).Left = c.Left + (c.Width - .Shapes(nomimage).Width) / 2
     .Shapes(nomimage).Top = c.Top
     .Shapes(nomimage).LockAspectRatio = msoTrue
   End With
End If
End Sub

Sub Affiche_Image()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String                   ' Contiendra le nom de l'image
Dim Lg As Long                        ' Numéro de la dernière ligne colonne B

  Set Ws = Sheets("Feuil1")                                           ' Nom de la feuille

  Application.ScreenUpdating = False                                  ' Interdit le raffraîchissement d'écran

  Efface_Images

  With Ws

    For Lg = 1 To .Range("B65536").End(xlUp).Row                      ' Parcourt de toute la colonne B

      Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser
  
      On Error Resume Next                                            ' On s'affranchit des erreurs
      With .Pictures.Insert(Image).ShapeRange                         ' On insère l'image dont le nom est en colonne B
        .LockAspectRatio = msoFalse                                   ' On peut la redimmensionner comme on veut
        .Left = Ws.Cells(Lg, "C").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "C").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "C").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "C").Height                            ' hauteur
      End With
      If Err.Number > 0 Then                                          ' Si une erreur (image non présente)
        MsgBox .Cells(Lg, "B") & vbCr & "Image inexistante"           ' On le signale
      End If
    Next Lg
  End With
End Sub

Sub Efface_Images()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Sh As Shape                       ' Sert à manipuler les formes (images) déjà affichées

  Set Ws = Sheets("Feuil1")                                           ' Nom de la feuille

  With Ws

    For Each Sh In .Shapes                                            ' Parcourt de toute la collection formes (images)
      If Not Intersect(.Columns(3), Sh.TopLeftCell) Is Nothing Then   ' si elle est dans la colonne 3
        Sh.Delete                                                     ' On l'efface
      End If
    Next Sh
  End With

End Sub

   Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser

  Image = "D:\Images\XTRAIN\" & .Cells(Lg, "B")

[CODE]   Image = ThisWorkbook.Path & "\PHOTOS\" & .Cells(Lg, "B")        ' Répertoire à actualiser

    Image = .Cells(Lg, "B")

Sub EffaceMentShapeChamp()
On Error Resume Next
  For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$c$11")) Is Nothing Then s.Delete
  Next s
    For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Range("$c$25")) Is Nothing Then s.Delete
  Next s
End Sub
Sub insert1()
On Error Resume Next
répertoirePhoto = "E:\SA2E\AFFAIRES\MANCHE\VIRE\Technique\Phase_1\Fiches_Regards\Photos\" ' Adapter
Nom = Range("c11").Text
Set c = Range("c11").MergeArea
With ActiveSheet
Range("C11").Select
.Pictures.insert(répertoirePhoto & Nom).Name = Nom
.Shapes(Nom).Left = c.Left
.Shapes(Nom).Top = c.Top
.Shapes(Nom).LockAspectRatio = msoFalse
.Shapes(Nom).Height = c.Height
.Shapes(Nom).Width = c.Width
End With
End Sub

Sub insert2()
On Error Resume Next
répertoirePhoto = "E:\SA2E\AFFAIRES\MANCHE\VIRE\Technique\Phase_1\Fiches_Regards\Photos\" ' Adapter
Nom = Range("c25").Text
Set c = Range("c25").MergeArea
With ActiveSheet
Range("C25").Select
.Pictures.insert(répertoirePhoto & Nom).Name = Nom
.Shapes(Nom).Left = c.Left
.Shapes(Nom).Top = c.Top
.Shapes(Nom).LockAspectRatio = msoFalse
.Shapes(Nom).Height = c.Height
.Shapes(Nom).Width = c.Width
End With
End Sub