使用 VBA 一次性压缩 PowerPoint 演示文稿的所有图片

Question

我有自动生成的 PowerPoint 演示文稿，其中包含大量图片。 PowerPoint有一个“压缩图片”功能来降低分辨率。

我正在寻找以相同分辨率压缩宏演示中的所有图片的 VBA 代码。

换句话说，“压缩图片”和“仅应用于此图片”框未选中。

下面的代码逐步遍历所有图片，但我想压缩而不弹出框选择。

我如何（以编程方式）逐步浏览所有图片并让用户选择压缩？

我无法适应这篇文章中的宏。

另外，我不知道在 VBA 中设置“HD”、“Print”或“Email”分辨率的字母。是吗 ？ :

SendKeys "%h", True
SendKeys "%p", True
SendKeys "%e", True

当我在 PowerPoint 中手动运行该代码时，该代码可以工作。

当我从Python作为自动命令行启动时，有时它可以工作，有时它会自动运行宏但不压缩图片。
另外，每次我运行宏时，它都会停用“Num lock”键盘按钮（可能是因为 DoEvents ？）。

Sub Compress_Picture_print_quality()
    Dim shp As Shape
    Dim sld As Slide
    Dim get_out As Boolean
    Dim ppt As Presentation
       
    get_out = False
    For Each sld In ActivePresentation.Slides
        sld.Select
        For Each shp In sld.Shapes
            If shp.Type = msoPicture Then
                shp.Select
                Application.CommandBars.ExecuteMso "PicturesCompress"
                SendKeys "%(p)",True 'or i.g. w for web, or e for email compression
                SendKeys "%(a)",False
                SendKeys "(ENTER)",True
                DoEvents ' I think this desactivates the Num Lock pad button of my keyboard. I have no clue why so
                get_out = True
                Exit For
            End If
        Next shp
        If get_out Then
            Exit For
        End If
    Next sld

    'Now I want to save the presentation and close it without closing other open PowerPoint files

    With Application.ActivePresentation
        If Not .Saved And .Path <> "" Then .Save
    End With

    If PowerPoint.Application.Version >= 9 Then
        PowerPoint.Application.Visible = msoTrue
    End If
    PowerPoint.ActivePresentation.Window(1).Close
End Sub

用于运行 VBA 代码的子进程命令。

import os
import subprocess    
os.chdir(r"C:\my_dir")
path_to_ppt_exe = r"C:\POWERPNT.EXE"
command = path_to_ppt_exe + ' /M "presentation.ppt" Compress_Picture_print_quality'
subprocess.run(command)

Answer 1

每行包含一个带有下划线的字母，代表带有 Alt 键的键盘快捷键。例如：

使用默认...——这意味着快捷方式是