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

我试图自动生成报告作为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的组合来做这个，但是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