Need a macro to insert and KEEP multiple pictures in multiple sheets in excel

[heraldita]

Hello,
Can somebody help me, I need a macro which not only insert, but also to copy and keep multiple pictures in multiple sheets in Excel. Till now I succeeded to find over the net a macro which inserts the pictures, but when I move them in another folder, they disappear from the file.

I need to amend this code below in a way to keep the pictures in the file, even if they are moved to another folder. Also, I need the pictures to be visible when I send this file to another person via email for example. Here is the code which inserts the pictures (but seems to only make links to them):

Public Sub Insert_Picture()
Dim myPicture As Variant
Dim myCell As Range
Dim lLoop As Long
Dim Sht As Worksheet
Dim arrSheets() As Variant
Dim n As Long, i As Long
Dim aPicture As Picture
Dim WB As Workbook
Dim Res As Variant


Set WB = ThisWorkbook


On Error Resume Next
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png),*.gif; *.jpg; *.bmp; *.tif *.png", , "SELECT FILE(S) TO IMPORT", MultiSelect:=True)
If VarType(myPicture) = vbBoolean Then
MsgBox "NO FILES SELECTED"
Else
n = 1
If IsArray(myPicture) Then
For lLoop = LBound(myPicture) To UBound(myPicture)
With WB.Sheets("Sheet" & n)
ReDim Preserve arrSheets(i To n)
arrSheets = .Name
Set myCell = .Range("I4:S26")
Set aPicture = .Pictures.Shapes.AddShape msoShapeRectangle 50, 50, iWidth, iHeight(myPicture(lLoop,msoFalse, msoTrue, MyLeft, MyTop, -1, -1))
.Pictures.Shapes(ActiveSheet.Shapes.Count).Fill.UserPicture
With myCell
aPicture.Top = .Top
aPicture.Left = .Left
aPicture.Width = .Width
aPicture.Height = .Height
aPicture.Placement = xlMoveAndSize

End With
End With
n = n + 1
Next lLoop
End If
End If


On Error GoTo XIT
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With


For Each Sht In WB.Worksheets
Res = Application.Match(Sht.Name, arrSheets, 0)
If IsError(Res) Then
Sht.Delete
End If
Next Sht


MsgBox "Copy Completed"


XIT:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub


Thank you in advance to all!

 

[Andrew Poulsom]

Welcome to MrExcel.

Check out the AddPicture method of the Shapes collection in VBA Help. It has a SaveWithDocument argument.

 

[heraldita]

Hi, thanks, but this doesn't help much, as I'm a newbie with the macros

 

[Andrew Poulsom]

Your code doesn't compile, but instead of:

Set aPicture = .Pictures.Shapes.AddShape msoShapeRectangle 50, 50, iWidth, iHeight(myPicture(lLoop,msoFalse, msoTrue, MyLeft, MyTop, -1, -1))
.Pictures.Shapes(ActiveSheet.Shapes.Count).Fill.UserPicture

try:

Set aPicture = .Shapes.AddPicture(myPicture(lLoop), False, True, 100, 100, 100, 100)