Help inserting pictures with macro

[excelhelp19]

Hello, I am using the following code to insert a list of pics, it inserts a link to the pics instead of pasting the pics, can someone help

Sub InsertPictures()
'Application.ScreenUpdating = False
'ThisWorkbook.Worksheets("CONTENTS").Visible = xlVisible
Dim CONT As Worksheet
Set CONT = ThisWorkbook.Worksheets("CONTENTS")
Dim RNG As Range
Dim MYCELL As Range
Dim WS As String
Dim T As Worksheet
Dim P As String
Set RNG = CONT.Range("A4:A500")
For Each MYCELL In RNG
If MYCELL <> "" Then
WS = MYCELL
P = MYCELL.Offset(0, 3)
Worksheets(WS).Select
Worksheets(WS).Range("A16").Select
ActiveSheet.Pictures.Insert(ThisWorkbook.PATH & "\PHOTO" & P).Select
With Selection
.Left = Range("A16").Left
.Top = Range("A16").Top
.ShapeRange.Width = 1030#
.ShapeRange.Rotation = 0#
End With
End If
Next
End Sub

 

[tonyyy]

excelhelp19,

Welcome to the Board.

The Pictures.Insert method doesn't save the picture with the file, so if you're trying to share or distribute the file the user will only see a link. You might try changing this line...

ActiveSheet.Pictures.Insert(ThisWorkbook.PATH & "\PHOTO" & P).Select

...with the following...

ActiveSheet.Shapes.AddPicture(ThisWorkbook.Path & "\PHOTO" & P, True, True, 100, 100, 86, 129).Select

You'll need to adjust the arguments - Left, Top, Width, Height.

Cheers,

tonyyy

 

[excelhelp19]

This is what the code actually looks like

Sub Picture()
'Application.ScreenUpdating = False
'ThisWorkbook.Worksheets("CONTENTS").Visible = xlVisible
Dim CONT As Worksheet
Set CONT = ThisWorkbook.Worksheets("CONTENTS")
Dim RNG As Range
Dim MYCELL As Range
Dim WS As String
Dim T As Worksheet
Dim P As String
Dim PATH As String
Set RNG = CONT.Range("A4:A500")
For Each MYCELL In RNG
If MYCELL <> "" Then
WS = MYCELL
P = MYCELL.Offset(0, 3)
Worksheets(WS).Select
Worksheets(WS).Range("A16").Select
ActiveSheet.Pictures.Insert(ThisWorkbook.PATH & "\PHOTO" & P).Select
With Selection
.Left = Range("A16").Left
.Top = Range("A16").Top
.ShapeRange.Width = 1030#
.ShapeRange.Rotation = 0#
End With
End If
Next
End Sub

 

[excelhelp19]

Sub Picture()
'Application.ScreenUpdating = False
'ThisWorkbook.Worksheets("CONTENTS").Visible = xlVisible
Dim CONT As Worksheet
Set CONT = ThisWorkbook.Worksheets("CONTENTS")
Dim RNG As Range
Dim MYCELL As Range
Dim WS As String
Dim T As Worksheet
Dim P As String
Dim PATH As String
Set RNG = CONT.Range("A4:A500")
For Each MYCELL In RNG
If MYCELL <> "" Then
WS = MYCELL
P = MYCELL.Offset(0, 3)
Worksheets(WS).Select
Worksheets(WS).Range("A16").Select
ActiveSheet.Pictures.Insert(ThisWorkbook.PATH & "\PHOTO" & P).Select
With Selection
.Left = Range("A16").Left
.Top = Range("A16").Top
.ShapeRange.Width = 1030#
.ShapeRange.Rotation = 0#
End With
End If
Next
End Sub

 

[excelhelp19]

I tried that, it didn't work. Gives me a error on that line

 

[tonyyy]

Not surprised, since the original line also produced an error (for me). What error number / description are you getting?

 

[excelhelp19]

Not surprised, since the original line also produced an error (for me). What error number / description are you getting?

Got it fixed with this.

ActiveSheet.Shapes.AddPicture(ThisWorkbook.PATH & "\photo\" & P, False, True, 1, 1, 1, 1).Select

 

[excelhelp19]

With the original line you have to have the pictures in a folder called "photo" in the same folder the spreadsheet is in.

 

[excelhelp19]

And they have to be .PNG file type

 

[tonyyy]

The missing "" would have been my suggestion. Glad you got it working...