How to insert images from a folder using VBA CODE and share them

[Mouga90]

HI All,

I am totally new to Macro and VBAs,

with the below code I am only able to insert pictures from a folder using a hyperlink on excel to retrieve the images

is some able to show me how

1 - I can amend the code in such a way that, when an image is not in the folder or the link is wrong, the code automatically moves on to the next cell underneath without stopping.
2 - How can I remove the link on those images and paste them as values so I can easily share the file for others to see them?


Here is the code

Sub InsertImageLineup()



Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim item As Range



Set rng = Range("c4:c1000")
For Each item In rng
pic = item.Offset(0, -1)
If pic = "" Then Exit Sub
Set myPicture = ActiveSheet.Pictures.Insert(pic)

With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = item.Width
.Height = item.Height
.Top = Rows(item.Row).Top
.Left = Columns(item.Column).Left
.Placement = xlMoveAndSize

End With

Next



End Sub




Again i copied this code and was able to amend it in order to suit my needs.

Thanks

 

[Domenic]

I have re-written your macro so that it instead uses the AddPicture method of the Shapes object. Note, as a result, myPicture is declared as a Shape instead of a Picture.

Sub InsertImageLineup()

    Dim pic As String
    Dim myPicture As Shape
    Dim rng As Range
    Dim item As Range
   
    Set rng = Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row) 'range from B4 to the last used row in Column B
   
    For Each item In rng
        If Len(item) > 0 Then 'check if cell is blank
            If Len(Dir(item.Value, vbNormal)) > 0 Then 'check if file exists
                With item.Offset(, 1)
                    Set myPicture = ActiveSheet.Shapes.AddPicture( _
                        Filename:=item.Value, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=.Left, _
                        Top:=.Top, _
                        Width:=.Width, _
                        Height:=.Height)
                End With
                myPicture.Placement = xlMoveAndSize
            End If
        End If
    Next

End Sub

Hope this helps!

 

[Mouga90]

I have re-written your macro so that it instead uses the AddPicture method of the Shapes object. Note, as a result, myPicture is declared as a Shape instead of a Picture.

Sub InsertImageLineup()

    Dim pic As String
    Dim myPicture As Shape
    Dim rng As Range
    Dim item As Range
  
    Set rng = Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row) 'range from B4 to the last used row in Column B
  
    For Each item In rng
        If Len(item) > 0 Then 'check if cell is blank
            If Len(Dir(item.Value, vbNormal)) > 0 Then 'check if file exists
                With item.Offset(, 1)
                    Set myPicture = ActiveSheet.Shapes.AddPicture( _
                        Filename:=item.Value, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=.Left, _
                        Top:=.Top, _
                        Width:=.Width, _
                        Height:=.Height)
                End With
                myPicture.Placement = xlMoveAndSize
            End If
        End If
    Next

End Sub

Hope this helps!

Thank you sooooooooooo much!!!!!!.

This is a life saver it works really well.

I cant thank you enough !!!!

 

[Domenic]

That's great, I'm really glad I could help.

Cheers!