PowerPoint宏逐图压缩：如何等待用户完成对话框操作？

原代码的核心问题是：调用Application.CommandBars.ExecuteMso弹出「压缩图片」对话框后，VBA会立刻继续执行循环，不会等待用户完成对话框操作。以下是两种可行的解决办法：

方法一：调用Windows API等待对话框关闭 #

通过Windows API识别「压缩图片」对话框窗口，强制代码暂停直到用户关闭该对话框。

完整代码： #

' 声明Windows API函数（适配64位Office，32位可去掉PtrSafe）
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long

Sub Compress_Pictures_WithWait()
    Dim shp As Shape
    Dim sld As Slide
    Dim hwndDialog As LongPtr
    Dim processId As Long
    Dim hProcess As LongPtr
    
    ' 遍历演示文稿的每张幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历当前幻灯片的所有形状
        For Each shp In sld.Shapes
            If shp.Type = msoPicture Then
                shp.Select
                ' 调用内置压缩图片对话框
                Application.CommandBars.ExecuteMso "PicturesCompress"
                ' 发送Alt+W自动选中Web分辨率（150ppi）
                SendKeys "%W", True
                
                ' 查找对话框窗口（中文Office标题为"压缩图片"，英文需改为"Compress Pictures"）
                hwndDialog = FindWindow(vbNullString, "压缩图片")
                If hwndDialog <> 0 Then
                    ' 获取对话框所属进程ID
                    GetWindowThreadProcessId hwndDialog, processId
                    ' 打开进程获取句柄
                    hProcess = OpenProcess(&H100000, False, processId)
                    If hProcess <> 0 Then
                        ' 无限等待直到对话框关闭
                        WaitForSingleObject hProcess, &HFFFFFFFF
                        ' 关闭进程句柄释放资源
                        CloseHandle hProcess
                    End If
                End If
            End If
        Next shp
    Next sld
End Sub

注意事项： #

• 窗口标题需匹配你的Office语言版本，英文版本要将"压缩图片"改为"Compress Pictures"
• 32位Office需删除所有PtrSafe关键字

方法二：自定义对话框直接压缩图片（无需依赖内置对话框） #

跳过内置对话框，通过VBA直接实现图片压缩逻辑，同时用自定义弹窗让用户选择分辨率，完全避免等待问题。

完整代码： #

Sub Compress_Pictures_CustomDialog()
    Dim shp As Shape
    Dim sld As Slide
    Dim resolutionChoice As Integer
    
    ' 遍历每张幻灯片
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.Type = msoPicture Then
                ' 弹出自定义选择对话框
                resolutionChoice = MsgBox("为图片[" & shp.Name & "]选择压缩分辨率:" & vbCrLf & _
                                        "1 - 邮件分辨率 (96ppi)" & vbCrLf & _
                                        "2 - 网页分辨率 (150ppi，默认)" & vbCrLf & _
                                        "3 - 打印分辨率 (220ppi)", _
                                        vbQuestion + vbDefaultButton2, "选择压缩参数")
                
                ' 根据用户选择执行压缩
                Select Case resolutionChoice
                    Case 1
                        shp.PictureFormat.Compress _
                            FileSize:=msoCompressDocument, _
                            Resolution:=msoResolutionWeb
                    Case 2
                        shp.PictureFormat.Compress _
                            FileSize:=msoCompressDocument, _
                            Resolution:=msoResolutionPrint
                    Case 3
                        shp.PictureFormat.Compress _
                            FileSize:=msoCompressDocument, _
                            Resolution:=msoResolutionHigh
                    Case Else
                        ' 用户取消，跳过当前图片
                        Exit Select
                End Select
            End If
        Next shp
    Next sld
End Sub

优势： #

• 完全由VBA控制流程，无等待问题
• 不受Office语言版本限制
• 可自定义分辨率选项和提示内容

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