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

So I have a macro assigned to a command button. when pressed it opens a dialogue box for user to import a picture file. Then it resizes the image and puts it on a specific cell. But If I move the original picture file location, the image disappears in Excel. Is there any chance I can save it inside the excel file so that it will not matter if I move the original file location.

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

The code is as follow:

代码如下：

    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

2 个解决方案

#1

.Pictures.Insert doesn't seem to provide control over linking or imbedding.

.Pictures.Insert似乎没有提供对链接或嵌入的控制。

However you can use this instead

但是你可以改用它

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

#2

Adding to the answer by Chris, additionally, I wanted to maintain the aspect ratio of the downloaded image. The problem was the AddPicture method mandates the arguments for width and height both. The trick which worked was putting those values as "-1" and then changing only height with locked aspect ratio.

除此之外，还要添加Chris的答案，我想保持下载图像的宽高比。问题是AddPicture方法要求宽度和高度的参数。有效的诀窍是将这些值设为“-1”，然后仅使用锁定的纵横比改变高度。

    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

#1