问题
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.
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.
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.
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
Remember to update the SaveAs filename to be a valid folder on your system for it to work.
I'm on Windows 7 using PowerPoint 2013. This behavior likely exists in other versions as well.
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.
EDIT: 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
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.
EDIT: 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
回答1:
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
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 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."
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.
UPDATE:
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)
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.
来源：https://stackoverflow.com/questions/40796993/trigger-powerpoint-text-autofit-behavior-without-displaying-application-window