Need Help For Change VBA Code

[Bysystemroad]

Dear Users

You can see the VBA code that ı use in the below.

But ı need to transform to "ActiveSheet.Shapes.AddPicture" style.

I use in the below code for to take the photos in the relevant folder, which corresponds to the product codes in column B, put pictures to column A with.

But when ı send to my customer, they can't see pictures in the excel .

Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String
  
  sPath = "C:\Users\canberk.saka\Desktop\SS20 FOTOĞRAFLARI\SS 2020 IMAGES\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
  
  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
  
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
      Set objPic = ActiveSheet.Pictures.Insert(sPath & sFile)
      With Range("A" & i)
        objPic.ShapeRange.LockAspectRatio = msoFalse
        objPic.Top = .Top
        objPic.Left = .Left
        objPic.Width = .Width
        objPic.Height = .Height
        objPic.Name = "img_" & i
      End With
    End If
  Next
End Sub

 

[Yongle]

Try this

Sub InsertPictures()
  Dim objPic As Shape, i As Long
  Dim sPath As String, sFile As String
  
  sPath = "C:\Users\canberk.saka\Desktop\SS20 FOTOGRAFLARI\SS 2020 IMAGES\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
  
  On Error Resume Next
    For Each objPic In ActiveSheet.Pictures
      If objPic.Name Like "img_*" Then
        objPic.Delete
      End If
    Next
  On Error GoTo 0
  
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
      With Range("A" & i)
        objPic = ActiveSheet.Shapes.AddPicture(Filename:=sPath & sFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
        objPic.Name = "img_" & i
      End With
    End If
  Next
End Sub

 

[Bysystemroad]

Thanks for quick answer.

But actions is like this.

 

[Yongle]

oops - I forgot to Set the object
amend this line

Set objPic = ActiveSheet.Shapes.AddPicture(Filename:=sPath & sFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)

 

[Bysystemroad]

Thanks for help

But Still same action

 

[Yongle]

Is the messagebox giving the correct path to your image?

INSERT THIS LINE
MsgBox sPath & sFile
AVOVE THIS LINE
        Set objPic = ActiveSheet.Shapes.AddPicture(Filename:=sPath & sFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)

 

[Bysystemroad]

I'm grateful

Thank you so much, Yongle

 

[Yongle]

Does that mean you have solved the problem?

 

[Bysystemroad]

Yes yongle

I have solved thanks for everything