在不显示应用程序窗口的情况下触发 PowerPoint 文本自动调整行为 [英] Trigger PowerPoint text autofit behavior without displaying Application Window

问题描述

我正在尝试自动生成 PowerPoint 演示文稿形式的报告.目前不能很好地工作的功能是 PowerPoint 的自动文本自动拟合，当文本溢出形状的边界时会发生这种情况.

I am attempting to automatically generate reports as PowerPoint presentations. The feature that is currently not working nicely is PowerPoint's automatic text auto-fitting that occurs when text overflows the boundaries of a shape.

如果形状设置为文本必须适合形状(这是默认设置)，则在添加文本时，形状中所有文本的字体大小会自动减小.此行为显然仅在应用程序可见时激活.这可能是因为实际呈现文本的行为会通知 PowerPoint 发生溢出并随后触发字体缩小.

If the shape is set so that text must fit the shape (which is the default), then the font sizes of all text in the shape are reduced automatically as text is added. This behavior apparently only activates when the application is visible. This is perhaps because the act of actually rendering the text is what informs PowerPoint that an overflow has occurred and a font down-size is then triggered.

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

When I make a presentation with the application window hidden, this auto-fitting doesn't occur. If I then open the presentation and modify the text box in any way, the font then shrinks. Hiding and then re-showing the slide also successfully updates the font. Performing these same actions from VBA while the presentation is hidden does not trigger the font size update.

有谁知道如何在不显示应用程序窗口的情况下触发 PowerPoint 的字体自动调整行为?

Does anyone know how to trigger PowerPoint's font auto-fit behavior without displaying the application window?

以下是演示问题的最小示例:

The following is a minimal example to demonstrate the problem:

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

Remember to update the SaveAs filename to be a valid folder on your system for it to work.

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

I'm on Windows 7 using PowerPoint 2013. This behavior likely exists in other versions as well.

我实际上是使用 python-pptx 和 COM 的组合在 Python 中执行此操作，但 VBA 示例执行相同的行为，我认为此示例比其他编程语言的相同内容更容易让人们玩.

I'm actually doing this with Python using a combination of python-pptx and COM, but the VBA example does the same behavior and I figure this example is much easier for folks to play with than the same thing from another programming language.

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

Here is a link to a file generated without ever showing the PowerPoint Application window. Editing text, hiding the slide, adding a slide, etc, will force an update that will trigger the auto-fit behavior. Example File

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

Here is a PowerPoint file with the macro that created the auto-generated file. Macro File

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

The code used below as a workaround to manually scale the text is commented out.

作为折衷的解决方法，以下代码会减小字体大小，直到文本适合……所以它是手动编码的自动适合.我添加了一些缩进级别来验证具有不同字体大小的级别都以相对方式缩放.我仍然想知道是否有办法让 PowerPoint 的自动调整完成它的工作，所以我将这个问题保持开放.

As a compromise workaround, the following code reduces the font size until the text fits... so it's a hand-coded auto-fit. I added some indent levels to verify that the levels with different font sizes are all scaling in a relative fashion. I'd still like to know if there's a way to let PowerPoint's autofit do it's thing, so I'll leave the question open.

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

推荐答案

我做了一个非常简单的测试，将文本框添加到一张空幻灯片.我设置了以下属性:

I made a very simple test by adding a text box to an empty slide. I set the following properties:

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

然后我将窗口最小化，创建了一个新的演示文稿(以便成为活动窗口)，然后通过 VBE 立即窗口以编程方式将一长串文本添加到第一个演示文稿中的形状:

I then minimised the window, created a new presentation (so that becomes the active window) and then programmatically added a long string of text to the shape in the first presentation via the VBE Immediate window:

Presentations(1).Slides(1).Shapes(1).TextFrame.TextRange.Text="Lorem ipsum dolor sat amet, consectetuer adipiscing elit. Maecenas porttitor congue massa. Fusce posuere, magna sed pulvinar ultricies, purus lectusmalesuada libero，坐 amet commodo magna eros quis urna."

Presentations(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 缩略图堆栈上时，我已经可以看到文本大小已减小.所以看起来自动适应功能对我有用.

On moving the mouse over the PowerPoint stack of thumbnails in the Windows task bar, I could already see that the text size had been reduced. So it seems the auto fit feature is working for me.

更新:

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

So, it appears that the AutoSize function isn't being applied even if you set the pres to have a visible (minimised or other) window because the pres is closed before PowerPoint has a chance to update it. I tested the theory that PowerPoint isn't updating the view until the code stops by changing one line of your code:

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

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

I then set a break point on your SaveAs line. When the code is interrupted, you can see that the AutoSize works and when it's left to run freely, AutoSize doesn't work. The same happens if I run it with a visible window and with your last two lines commented out. So this looks like PowerPoint can't refresh the content while code is running and/or a window is in view when the code finishes. I tried all sorts of combinations of DoEvents and Sleep (using the WinAPI) and nothing worked. I also noted that when using Sleep, the window appeared with a slide but had no content on it (as if PowerPoint was waiting until the code execution has finished before refreshing the window). So I'm left thinking that unless you allow your code to complete before closing the file, this isn't going to work.

这篇关于在不显示应用程序窗口的情况下触发 PowerPoint 文本自动调整行为的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！