vba中工作表中存在的矩形形状填充图片

Question

我的工作表中已经有一张图片，并且我有矩形形状。 现在我想通过vba代码将该图片填充到矩形形状中。

Dim img As Picture
    
Set img = ThisWorkbook.Worksheets("Sheet1").Pictures("Pic01").Copy
shape1.Fill.UserPicture (img)

运行该代码后，shape1 未填充。 （如果我将 img 对象更改为一个图片文件路径，则 shape1 被填充）。

=> 如何在没有图片文件路径的情况下将图片填充到shape1？

非常感谢。

Answer 1

似乎没有直接的方法通过 VBA 用剪贴板中的图像填充形状。但是，可以采取变通解决方案。

Sub FillShapeWithImage()
    Dim strPath As String, sFname As String
    Dim shp As Shape, img As Shape
    Worksheets("Sheet1").Select
    Set img = ActiveSheet.Shapes("Pic01")
    Set shp = ActiveSheet.Shapes("Rectangle 14")
    strPath = ThisWorkbook.Path
    img.CopyPicture xlScreen, xlBitmap
    sFname = strPath & "\" & Format(Now(), "yyyymmddhhmmss") & ".png"
    Application.ScreenUpdating = False
    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
        .Parent.Select
        .Paste
        .Export sFname, "png"
        .Parent.Delete
    End With
    shp.Fill.UserPicture sFname
    On Error Resume Next
    Kill sFname
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub