inserting pictures with vba - vba

Question

I am trying to insert an image using VBA, however the code only links the image into the excel sheet. once I delete the images the linked images in the sheet are deleted. I need to adjust the code to save the linked image into the workbook. this is the code I have
Sub DeleteImages()
For Each s In ActiveSheet.Shapes
s.Delete
Next s
ActiveSheet.Cells.Rows.AutoFit
End Sub
Sub AddImages()
Dim sImgFile As String
sPath = ActiveWorkbook.Path & Application.PathSeparator
Set ws = ActiveSheet
ltop = Val(InputBox("Provide height", "Height"))
'lwid = Val(InputBox("Provide width", "Width"))
'On Error GoTo StopIt
If ltop > 0 Then 'And lwid > 0
ws.Range("E1").ColumnWidth = 1
For l = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A" & l).Rows.AutoFit
sImgFile = Dir(sPath & ws.Range("B" & l).Value & ".*")
If sImgFile <> "" Then
With ws.Pictures.Insert(sPath & sImgFile)
With .ShapeRange
.LockAspectRatio = msoTrue
'.Width = lwid
.Height = ltop
i = 1
ws.Range("E" & l).ColumnWidth = Application.WorksheetFunction.Max(.Width / 5.3, ws.Range("E" & l).ColumnWidth)
ws.Range("E" & l).RowHeight = .Height + 4
End With
.Left = ws.Cells(l, 5).Left
.Top = ws.Cells(l, 5).Top + 2
.Placement = 1
.PrintObject = True
Call Macro1(Range("E" & l))
End With
End If
Next l
End If
For Each s In ActiveSheet.Shapes
s.Left = ws.Range("E1").Left + (ws.Range("E1").Width - s.Width) / 2
Next s
StopIt:
On Error GoTo 0
End Sub

Answer 1

Try this:
If sImgFile <> "" Then
With ws.Shapes.AddPicture(sPath & sImgFile, linktofile:=msoFalse, _ savewithdocument:=msoCTrue)
.LockAspectRatio = msoTrue
'.Width = lwid
.Height = ltop
i = 1
ws.Range("E" & l).ColumnWidth = Application.WorksheetFunction.Max(.Width / 5.3, ws.Range("E" & l).ColumnWidth)
ws.Range("E" & l).RowHeight = .Height + 4
.Left = ws.Cells(l, 5).Left
.Top = ws.Cells(l, 5).Top + 2
.Placement = 1
.ControlFormat.PrintObject = True
Call Macro1(Range("E" & l))
End With
End If