如何将UserForm中的图片按原比例缩小至指定百分比？

需求背景 #

需要将UserForm中动态加载的图片按原尺寸的指定百分比缩小，要求保持画质、避免拉伸变形。当前动态加载流程为：截取区域快照转形状→导出到本地文件夹→UserForm读取图片。

已尝试的无效操作：

• 使用Me.Image1.PictureSizeMode = 3（即fmPictureSizeModeStretch）：图片被强制拉伸适配控件窗口，画质大幅下降
• 直接设置Me.Image1.Picture.Height = 300：无法手动修改Picture对象的尺寸属性，操作无效

解决思路 #

UserForm的Image控件中，Picture对象是只读的，无法直接修改其尺寸。因此最优方案是在导出图片阶段就按比例缩小尺寸，让UserForm直接加载已经调整好大小的图片，从根源避免拉伸和画质损失。

修改后的代码 #

Sub Pict(n)
    Dim Strpath As String
    Dim Pic As Object
    Dim ws As Worksheet
    Dim cht As Excel.ChartObject
    Dim scaleFactor As Double ' 定义缩放比例，按需调整

    ' 设置缩放比例：0.5代表缩小至原尺寸的50%，可自行修改
    scaleFactor = 0.5

    Set ws = Sheets("Model")

    With ListBox1
        Set Pic = ws.Shapes(.List(n))

        Strpath = ThisWorkbook.Path & "\Temp.jpg"
        
        ' 按缩放比例创建ChartObject，导出的图片尺寸将与此一致
        Set cht = ws.ChartObjects.Add(782, 782, Pic.Width * scaleFactor, Pic.Height * scaleFactor)
        cht.Name = "Indic_cht_0"

        ' 等待系统处理资源，防止粘贴失败
        Dim i As Integer
        For i = 1 To 3
            DoEvents
        Next i

        cht.Chart.Paste
        cht.Chart.Export Strpath
        cht.Delete
        Set cht = Nothing

        ' 加载缩小后的图片，选择合适的显示模式
        Me.Image1.PictureAlignment = fmPictureAlignmentTopLeft
        ' fmPictureSizeModeClip：只显示控件范围内的图片，不拉伸
        ' fmPictureSizeModeZoom：按比例适配控件，保持原图比例不变形
        Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
        Me.Image1.Picture = LoadPicture(Strpath)
    End With
End Sub

关键修改说明 #

1. 新增缩放比例变量：通过scaleFactor直接控制图片缩小比例，数值可根据需求灵活调整
2. 调整ChartObject尺寸：创建ChartObject时使用Pic.Width * scaleFactor和Pic.Height * scaleFactor，确保导出的图片本身就是缩小后的尺寸
3. 优化图片显示模式：选择fmPictureSizeModeZoom或fmPictureSizeModeClip，避免拉伸图片导致的画质损失

内容的提问来源于stack exchange，提问作者OneTwentyTo