Insert a picture and link it to the worksheet

[Laure]

Hi all,

I am not a pro of VBA but I managed to find an awesome code that allows me to insert pictures in column A according to the names written in column B. These pictures are loaded from the same file on the computer.

Here is the code :

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 & "\CJ\" & .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, "A").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "A").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "A").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "A").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

The problem is that if I change the images in the root file or if I delete them, Excel does not display them anymore...

I found that with the LinkToFile and SaveWithDocument options, I could change this so that the pictures are definitely linked with the worksheet but I don't know how to properly write the code...

If somebody can help me that would be awesome.

Thank you all !!

 

[Useful]

Hi and welcome!
try this

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 & "\CJ\" & .Cells(Lg, "B")        ' Répertoire à actualiser
        
      On Error Resume Next                                            ' On s'affranchit des erreurs
     
        lft = Ws.Cells(Lg, "A").Left
        tp = Ws.Cells(Lg, "A").Top
        Wdh = Ws.Cells(Lg, "A").Width
        Hht = Ws.Cells(Lg, "A").Height
        
     Application.ActiveSheet.Shapes.AddPicture Image, False, True, lft, tp, Wdh, Hht


      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

 

[Laure]

Dear Useful !

Thank you for answering me but I tried the code and it's not working, the error says "Compilation error: Undefined variable"... I know that the Shapes.AddPicture is the right function to use but I don't know enough to kow how to incorporate it into the code. Would you have by any chance another idea ?

 

[Useful]

Dear Laure!

try to check the string below

Image = ThisWorkbook.Path & "\CJ\" & .Cells(Lg, "B")

If "CJ" isn't the folder name that your pictures located.

 

[RoryA]

In the original code, try changing this:

      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, "A").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "A").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "A").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "A").Height                            ' hauteur
      End With

to this:

ws.Shapes.AddPicture(filename:=Image, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
Left:=ws.Cells(Lg, "A").Left, Top:=ws.Cells(Lg, "A").Top, Width:=ws.Cells(Lg, "A").Width, _
Height:=ws.Cells(Lg, "A").Height).LockAspectRatio = msoFalse

 

[Laure]

Dear Useful,

Yes CJ is the name of the folder where all the pictures are located !

Dear RoryA,

I tried your solution but the error is as follow : an error has occured when importing this file : C:// CJ then "Execution error 1004: error defined by the application or the object"

Here is the code I tried :

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 & "\CJ\" & .Cells(Lg, "B")        ' Répertoire à actualiser
        
      Ws.Shapes.AddPicture(Filename:=Image, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
Left:=Ws.Cells(Lg, "A").Left, Top:=Ws.Cells(Lg, "A").Top, Width:=Ws.Cells(Lg, "A").Width, _
Height:=Ws.Cells(Lg, "A").Height).LockAspectRatio = msoFalse


      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

 

[Useful]

Dear Useful,

Yes CJ is the name of the folder where all the pictures are located !

Dear RoryA,

I tried your solution but the error is as follow : an error has occured when importing this file : C:// CJ then "Execution error 1004: error defined by the application or the object"

Here is the code I tried :

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 & "\CJ\" & .Cells(Lg, "B")        ' Répertoire à actualiser
        
      Ws.Shapes.AddPicture(Filename:=Image, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
Left:=Ws.Cells(Lg, "A").Left, Top:=Ws.Cells(Lg, "A").Top, Width:=Ws.Cells(Lg, "A").Width, _
Height:=Ws.Cells(Lg, "A").Height).LockAspectRatio = msoFalse


      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

Hello first mark - Efface_Images line as text (or remove) and after line below

Image = ThisWorkbook.Path & "\CJ\" & .Cells(Lg, "B")

use

on error resume next

and it'll work fine

 

[Laure]

It works just perfectly now !!

Thank you so much for all your help !!

 

[Useful]

It works just perfectly now !!

Thank you so much for all your help !!

Glad for you!