Excel VBA - Shapes.AddPicture vs Pictures.Insert into spreadsheet from mapped drive - excel

Question

I have been using an Excel VBA macro to add images to my spreadsheet lists from a folder on our office server. The list exports from my database software with the containing folder and image name in Column A (e.g. 038/19761809.jpg). I now need to send these documents to persons outside of my office without access to our server so I am trying to switch from using ActiveSheet.Pictures.Insert to using the more correct ActiveSheet.Shapes.AddPicture. The goal is to have the image files embed in the document rather than just linking to the files on our office server.
This code (using Pictures.Insert) inserts the images as links. When I email the spreadsheet to off-site users, the linked images "break" as recipient's computer cannot find them (because their computer is not on our local network).
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
On Error GoTo 0
With Selection
.Left = myleft + 4
.Top = mytop + 4
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 115#
.ShapeRange.Rotation = 0#
End With
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
I have modified my code to use the formatting for Shapes.AddPicture. Here is the new code:
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Shapes.AddPicture(Filename:=picname, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myleft + 4, Top:=mytop + 4, LockAspectRatio:=msoTrue, Height:=115#, Rotation:=0#).Select
On Error GoTo 0
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
When I try to run the new macro Excel just puts up my "Unable to Find Photo" error message. Can you help me find what I did wrong? Thanks for any help!

Answer 1

You have 2 extra arguments in Shapes.AddPicture (LockAspectRatio, Rotation), and a missing one (Width).
See more details about Shapes.AddPicture, and your corrected code below:
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim sht As Worksheet: Set sht = ActiveSheet
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
With sht.Shapes
.AddPicture _
Filename:=picname, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myleft + 4, _
Top:=mytop + 4, _
Width:=-1, _
Height:=115
End With
On Error GoTo 0
Exit Sub
ErrNoPhoto:
Debug.Print "Unable to Find Photo" 'Shows message box if picture not found
End Sub
PS: I recommend you to read about avoiding to use .Select in everything...