如何使用VBA将插入的图片保存在excel中

Question

我试图将一些保存在桌面上的图片插入到excel文件中。

我发现一些在线代码运行良好。但这些插入的图片似乎没有与文档一起保存——当我在另一台计算机上打开文件时，插入的图片不会显示。我想知道我应该如何调整代码，以便将插入的图片保存在excel中？如果可以使用VBA，如何将插入的图片调整为50%的尺寸？我对VBA完全陌生。很抱歉出现这个基本问题。

Sub add_pictures_R2()
Dim i%, ppath$
For i = 2 To 145   
' file name at column A
ppath = "C:Usersmynameoutput" & 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

您可以编辑文件的路径以与excel文件一起使用，也可以嵌入它。对于嵌入，我会看看这个。https://danny.fyi/embedding-and-accessing-a-file-in-excel-with-vba-and-ole-objects-4d4e7863cfff

这有点混乱，但你可以实现你想要做的事情，至少文件在文档中，而不是试图用它传输所有内容

Answer 2

试试这个(使用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:Usersmynameoutput" & 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

我从mrexcel的Jimmypop那里得到了答案。它奏效了。

Sub add_pictures_R2()
Const folderPath As String = "C:UsersYANGoutput"
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