使用VBA快速创建留白的图片填充矩形框

实例需求：在活动工作表中插入矩形框，然后填充德国国旗（国旗图片来源：https://upload.wikimedia.org/wikipedia/en/b/ba/Flag_of_Germany.svg），国旗周边留白。

注意：需要使用单个Shape对象实现如下图效果，不得使用两个Shape对象叠加。

示例代码如下。

Sub Demo()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        Shp.Delete
    Next
    Set Shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=200, Height:=120)
    With Shp
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = vbBlue
        .Line.Weight = 5
        .Fill.UserPicture "https://upload.wikimedia.org/wikipedia/en/b/ba/Flag_of_Germany.svg"
        With .PictureFormat.Crop
            Dim iW: iW = .PictureWidth
            Dim iH: iH = .PictureHeight
            Const OFFSET_PCT = 0.05  ' Modify as needed
            .PictureWidth = iW * (1 - 2 * OFFSET_PCT)
            .PictureHeight = iH * (1 - 2 * OFFSET_PCT * iW / iH)
        End With
    End With
    Debug.Print ActiveSheet.Shapes.Count
End Sub

【代码解析】
第3~5行代码删除活动工作表中的Shape对象。
第6行代码在工作表中添加一个矩形框。
第8行代码设置边框线条可见。
第9行代码设置边框线颜色为蓝色。
第10行代码设置边框线的线宽。
第11行代码在矩形框中填充图片。
本示例代码的核心部分在于如何剪裁填充图片。
第13行代码获取图片的宽度。
第14行代码获取图片的高度。
第15行代码设置留白的比例，大家可以自行修改。
第16行代码调整填充图片剪裁宽度。
第17行代码调整填充图片剪裁高度。
第20行代码在【立即窗口】中输出活动工作表中的Shape对象的个数。