使用vba在Excel中保存导入的图片

所以我有一个macros分配给一个命令button。 当按下它时打开一个对话框供用户导入一个图片文件。 然后调整图像大小并将其放在特定的单元格上。 但是，如果我移动原始图片文件的位置，图像在Excel中消失。 有没有什么机会可以把它保存在excel文件中，这样如果我移动原来的文件位置就没关系了。

代码如下：

Sub Add_Image() Application.ScreenUpdating = False Range("B18").Select 'varible Picture1 is inserted down below - ***change both*** Picture1 = Application.GetOpenFilename("Picture,*.JPG,Picture,*.JPEG,Picture,*.GIF,Picture,*.BMP") 'edit "("Picture,*.*")" section to add or chanve visible file types On Error GoTo ErrMsg ActiveSheet.Pictures.Insert(Picture1).Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 145 Selection.ShapeRange.Width = 282 Application.ScreenUpdating = True Exit Sub ErrMsg: MsgBox ("Failed to load Image"), , "Error" End Sub 

Answer 1

.Pictures.Insert似乎不提供控制链接或embedded。

但是，您可以使用此代替

 expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height) 

---

 Sub Add_Image() Dim pic As Object Dim rng As Range Application.ScreenUpdating = False Set rng = Range("B18") Set rng2 = Range("A1", rng.Offset(-1, -1)) 'varible Picture1 is inserted down below - ***change both*** Picture1 = Application.GetOpenFilename( _ "Picture,*.JPG,Picture,*.JPEG,Picture,*.GIF,Picture,*.BMP") 'edit "("Picture,*.*")" section to add or chanve visible file types On Error GoTo ErrMsg With Range("A1", rng.Offset(-1, -1)) Set pic = ActiveSheet.Shapes.AddPicture(Picture1, False, True, _ .Width, .Height, 282, 145) End With With pic .LockAspectRatio = msoFalse End With Application.ScreenUpdating = True Exit Sub ErrMsg: MsgBox ("Failed to load Image"), , "Error" End Sub 

Answer 2

此外，Chris还补充说，我想保持下载图像的宽高比。 问题是AddPicture方法强制宽度和高度的参数。 这个技巧是将这些值设置为“-1”，然后只改变locking高宽比的高度。

  Set picCell = cell.Offset(0, 1) Set pic = ActiveSheet.Shapes.AddPicture(fileString, False, True,_ picCell.Left + 10, picCell.Top + 10, -1, -1) With pic .LockAspectRatio = msoTrue .Height = 200 End With