How to save inserted pictures in excel using VBA? - excel

Question

I was trying to insert some pictures that are saved on my desktop to an excel file.
I found that some online codes worked well. But it seemed that those inserted pictures were not saved with the documents - the inserted pictures won't be displayed when I opened the file on another computer. I am wondering how I should tweak the codes so it can save the inserted pictures within the excel? If possible with VBA, how to adjust the inserted pictures to their 50% dimensions? I am completely new to VBA. Sorry for this basic question.
Sub add_pictures_R2()
Dim i%, ppath$
For i = 2 To 145
' file name at column A
ppath = "C:\Users\myname\output\" & CStr(Cells(i, 1).Value) & ".png"
If Len(Dir(ppath)) Then
With ActiveSheet.Pictures.Insert(ppath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 300
End With
.Left = ActiveSheet.Cells(i, 10).Left
.Top = ActiveSheet.Cells(i, 10).Top
.Placement = 1
.PrintObject = True
End With
End If
Next
End Sub

Answer 1

You can do either, edit the path of the file to go along with your excel file or you could embed it. For embedding I would look at this.
https://danny.fyi/embedding-and-accessing-a-file-in-excel-with-vba-and-ole-objects-4d4e7863cfff
Its a bit messy but you would achieve what you want to do with at least the file being in the document and not trying to transfer everything with it.

Answer 2

Try this (using Shapes.AddPicture)
Sub add_pictures_R2()
'Note - type identifiers such as `S`, `%` are very outdated...
Dim i As Long, ppath As String, ws As Worksheet, c As Range
Set ws = ActiveSheet 'use a specific/explicit sheet reference
For i = 2 To 145
ppath = "C:\Users\myname\output\" & CStr(ws.Cells(i, 1).Value) & ".png"
Set c = ws.Cells(i, 10) 'insertion point
'passing -1 to Width/Height preserves original size
With ws.Shapes.AddPicture(Filename:=ppath, linktofile:=msoFalse, _
savewithdocument:=msoTrue, _
Left:=c.Left, Top:=c.Top, Width:=-1, Height:=-1)
.LockAspectRatio = msoTrue
.Placement = xlMove
.Height = .Height / 2 'size to 50%
End With
Next i
End Sub

Answer 3

I got the answer from Jimmypop at mrexcel. It worked.
Sub add_pictures_R2()
Const folderPath As String = "C:\Users\YANG\output\"
Dim r As Long
Application.ScreenUpdating = False
With ActiveSheet
For r = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If Dir(folderPath & .Cells(r, "A").Value & ".png") <> vbNullString Then
.Shapes.AddPicture Filename:=folderPath & .Cells(r, "A").Value & ".png", _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveSheet.Cells(r, 10).Left, Top:=ActiveSheet.Cells(r, 10).Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height
Else
.Cells(r, "B").Value = "Not found"
End If
DoEvents
Next
End With
Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes
Select Case s.Type
Case msoLinkedPicture, msoPicture
s.ScaleHeight 0.5, msoTrue
s.ScaleWidth 0.5, msoTrue
Case Else
' Do Nothing
End Select
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub