如何修改Word VBA代码实现粘贴图片时自动压缩（Windows版Word）

现有两段可正常运行的Word VBA代码：

1. 第一段实现粘贴剪贴板图片并将其宽度设为1.5英寸
2. 第二段实现压缩当前文档所有图片至220ppi

需求是修改第一段代码，让粘贴图片时自动完成压缩，无需单独执行第二段代码。此前尝试使用InlineShapes.PictureFormat.Compression = True未成功。

修改后的完整代码 #

Sub ResizeSelectedPicture()
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    
    With Selection
        .PasteAndFormat (wdPasteDefault) ' 粘贴剪贴板内容
        .Start = .Start - 1 ' 调整选区起始位置以包含刚粘贴的图片
        If .InlineShapes.Count = 1 Then
            With .InlineShapes(1)
                .LockAspectRatio = msoTrue ' 锁定宽高比
                .Width = InchesToPoints(1.5) ' 设置宽度为1.5英寸
                ' 执行图片压缩，分辨率设为220ppi（打印级别）
                .PictureFormat.Compress _
                    FileName:="", _
                    Resolution:=wdPictureResolutionPrint
            End With
        End If
    End With
    
    Selection.MoveRight Unit:=wdCell
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler:
    MsgBox "操作出错：" & Err.Description, vbExclamation
    Application.ScreenUpdating = True
End Sub

关键修改说明 #

1. 替换不可靠的压缩方式：放弃原第二段代码中的SendKeys和ExecuteMso，改用Word VBA原生的PictureFormat.Compress方法，避免因界面状态变化导致的执行失败。
2. 正确指定压缩分辨率：wdPictureResolutionPrint常量对应Word内置的「打印(220 ppi)」选项，正好匹配需求的分辨率。
3. 修正之前的错误尝试：InlineShapes.PictureFormat.Compression是只读属性，无法直接赋值True，必须通过调用Compress方法来触发压缩操作。
4. 保留原有逻辑：保留了原代码中锁定宽高比、调整图片宽度以及选区移动的逻辑，确保原有功能不受影响。

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