在不显示应用程序窗口的情况下触发PowerPoint文本自动拟合行为

Question

我正在尝试自动生成作为PowerPoint演示文稿的报告。目前效果不佳的功能是PowerPoint的自动文本自动拟合功能，当文本溢出形状的边界时会出现这种功能。

如果形状设置为文本必须与形状匹配（这是默认设置），则在添加文本时，形状中所有文本的字体大小都会自动减小。这种行为显然只有在应用程序可见时才会激活。这可能是因为实际呈现文本的行为会通知PowerPoint发生溢出，然后触发字体缩小。

当我隐藏应用程序窗口时，不会发生这种自动拟合。如果我打开演示文稿并以任何方式修改文本框，字体就会缩小。隐藏并重新显示幻灯片也会成功更新字体。在演示文稿隐藏时从VBA执行这些相同的操作不会触发字体大小更新。

有人知道如何在不显示应用程序窗口的情况下触发PowerPoint的字体自动匹配行为吗？

下面是一个演示该问题的简单示例：

Sub new_presentation()

    Dim pres As Presentation
    Dim sl As Slide
    Dim textbox As Shape
    Dim tf As TextFrame
    Dim tr As TextRange

    Set pres = Application.Presentations.Add(WithWindow:=msoFalse)

'    For Each Layout In pres.SlideMaster.CustomLayouts
'        Debug.Print Layout.Name
'    Next

    Set sl = pres.Slides.AddSlide(1, pres.SlideMaster.CustomLayouts.Item(2))

    Set textbox = sl.Shapes.Placeholders(2)
    Set tf = textbox.TextFrame
    Set tr = tf.TextRange
    tr.Text = "Some text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text" & vbCrLf & _
                "More Text"

    pres.SaveAs FileName:="D:\Documents\Python\powerpoint\vba_demo.pptx"
    pres.Close
End Sub

请记住将SaveAs文件名更新为系统上的有效文件夹，以便其工作。

我在Windows 7上使用PowerPoint 2013。这种行为可能也存在于其他版本中。

我实际上是使用python-pptx和COM的组合来使用Python来做这件事，但是VBA示例做了同样的行为，我认为这个示例比另一种编程语言中的同样的东西更容易让人玩。

编辑：这里有一个链接，指向一个从未显示PowerPoint应用程序窗口的文件。编辑文本、隐藏幻灯片、添加幻灯片等将强制更新，从而触发自动调整行为。示例文件

这是一个PowerPoint文件，其中包含创建自动生成文件的宏

下面用作手动缩放文本的变通方法的代码被注释掉。

编辑：作为一个折衷的解决方法，下面的html" target="_blank">代码会减小字体大小，直到文本适合为止...所以这是一个手工编码的自动匹配。我添加了一些缩进级别，以验证不同字体大小的级别都以相对的方式缩放。我仍然想知道是否有办法让PowerPoint的自动匹配完成它的工作，所以我将保留这个问题。

Sub new_presentation()

    Dim pres As Presentation
    Dim sl As Slide
    Dim textbox As Shape
    Dim tf As TextFrame
    Dim tr As TextRange

    Set pres = Application.Presentations.Add(WithWindow:=msoFalse)

'    For Each Layout In pres.SlideMaster.CustomLayouts
'        Debug.Print Layout.Name
'    Next

    Set sl = pres.Slides.AddSlide(1, pres.SlideMaster.CustomLayouts.Item(2))

    Set textbox = sl.Shapes.Placeholders(2)
    Set tf = textbox.TextFrame
    Set tr = tf.TextRange
    tr.Text = "Row 1" & vbCrLf & _
                "Row 2" & vbCrLf & _
                "Row 3" & vbCrLf & _
                "Row 4" & vbCrLf & _
                "Row 5" & vbCrLf & _
                "Row 6" & vbCrLf & _
                "Row 7" & vbCrLf & _
                "Row 8" & vbCrLf & _
                "Row 9" & vbCrLf & _
                "Row 10" & vbCrLf & _
                "Row 11" & vbCrLf & _
                "Row 12" & vbCrLf & _
                "Row 13" & vbCrLf & _
                "Row 14"

    ' Indent some rows out to levels 2 and 3
    tr.Paragraphs(2, 1).IndentLevel = 2
    tr.Paragraphs(3, 3).IndentLevel = 3
    tr.Paragraphs(6, 1).IndentLevel = 2
    tr.Paragraphs(7, 3).IndentLevel = 3
    tr.Paragraphs(10, 1).IndentLevel = 2
    tr.Paragraphs(11, 3).IndentLevel = 3

    ' Get the max height for the text to fit in the box...
    h_max = textbox.Height - tf.MarginTop - tf.MarginBottom

    overflow = tr.BoundHeight - h_max

    iLoop = 0

    While overflow > 0 And iLoop < 20

        prev_overflow = overflow
        For i = 1 To tr.Paragraphs.Count
            Set p = tr.Paragraphs(i, 1)
            before = p.Font.Size
            after = Round(before * 0.9, 0)
            p.Font.Size = after
        Next

        overflow = tr.BoundHeight - h_max

        iLoop = iLoop + 1
        Debug.Print "Iteration: " & iLoop & " Overflow: " & overflow

    Wend

    pres.SaveAs FileName:="D:\Documents\Python\powerpoint\vba_demo.pptx"
    pres.Close
End Sub

Answer 1

我做了一个非常简单的测试，在一张空幻灯片上添加了一个文本框。我设置了以下属性：

.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' Shrink text on overflow
.TextFrame.WordWrap ' Wrap text in shape

然后，我最小化了窗口，创建了一个新的演示文稿（从而成为活动窗口），然后通过VBE即时窗口以编程方式向第一个演示文稿中的形状添加了一长串文本：

演讲（1）。幻灯片（1）。形状（1）。文本框架。文本范围。文本="Lorem ipsum dolor sit amet，consecetuer adipiscing elit。Maecenas porttitor congue Massa。Fusce posuere，magna ed pulvinar ultricies，purus lectus malesuada Libero，sit amet commodo magna eros quis urna。"

在Windows任务栏中将鼠标移到PowerPoint缩略图堆上时，我已经可以看到文本大小已减小。因此，自动装配功能似乎对我有效。

更新：

因此，即使您将pres设置为具有可见（最小化或其他）窗口，似乎也没有应用自动调整大小功能，因为在PowerPoint有机会更新它之前，pres已关闭。我测试了一种理论，即PowerPoint在代码停止之前不会更新视图，只需更改代码的一行即可：

Set pres = Application.Presentations.Add(WithWindow:=msoFalse)

然后我在SaveAs行上设置了一个断点。当代码被中断时，您可以看到AutoSize起作用，而当让它自由运行时，AutoSize不起作用。如果我在一个可见窗口中运行它，并且最后两行被注释掉，也会发生同样的情况。因此，在代码运行和/或代码完成时，PowerPoint无法刷新内容。我尝试了各种DoEvents和Sleep的组合（使用WinAPI），但都没有效果。我还注意到，在使用Sleep时，窗口中出现了一张幻灯片，但没有任何内容（就像PowerPoint在刷新窗口之前等待代码执行完成）。所以我一直在想，除非在关闭文件之前让代码完成，否则这是行不通的。