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文件名更新为系统上的有效文件夹，以使其正常工作。

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

我实际上是在使用python-pptx和COM的组合使用Python，但是VBA示例执行相同的行为，我认为这个示例对于人们来说比使用另一种编程语言的相同的东西更容易

编辑：以下是生成的文件的链接，但未显示PowerPoint应用程序窗口。编辑文本，隐藏幻灯片，添加幻灯片等将强制进行更新，以触发自动调整行为。 Example File

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

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

编辑：作为折衷的解决方法，以下代码减小了字体大小，直到文本适合...所以它是手动编码的自动调整。我添加了一些缩进级别来验证具有不同字体大小的级别是否都以相对方式缩放。我还是想知道是否有办法让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）.Slides（1）.Shapes（1）.TextFrame.TextRange.Text =“Lorem ipsum dolor sit amet，consectetuer adipiscing elit.Maecenas porttitor congue massa。Fusce posuere，magna sed pulvinar ultricies，purus lectus malesuada libero，sit amet commodo magna eros quis urna。“

将鼠标移到Windows任务栏中的PowerPoint缩略图堆栈上时，我已经看到文本大小已经减少。所以看起来自适应功能对我有用。

更新：

因此，即使您将pres设置为具有可见（最小化或其他）窗口，似乎也未应用AutoSize功能，因为在PowerPoint有机会更新之前，pres已关闭。我通过更改代码的一行来测试PowerPoint没有更新视图的理论，直到代码停止：

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

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

触发PowerPoint文本自动调整行为，而不显示应用程序窗口

1 个答案: