觸發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 

記住更新另存爲文件命名爲您的系統上有效的文件夾爲它工作。

我在Windows 7上使用PowerPoint 2013年這種行爲在其他版本可能同樣存在。

我實際上是在用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 

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存有悲坐阿梅特，consectetuer adipiscing ELIT保護者porttitor congue馬薩Fusce posuere，蚤SED枕。 ultricies，purus lectus malesuada libero，sit amet commodo magna eros quis urna。「

將鼠標移動到Windows任務欄中縮略圖的PowerPoint堆棧上時，我已經可以看到文本大小已經減小。所以看起來汽車貼合功能正在爲我工​​作。

UPDATE：

因此，看來，即使你設置PRES有一個可見的（最小化或其他）窗口，因爲PRES關閉PowerPoint中有機會之前不被應用的自動調整大小功能更新它。我測試的理論，PowerPoint中沒有更新的觀點，直到代碼將停止通過更改代碼的一行：

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

我然後設置你的另存爲行一個破發點。當代碼被中斷時，您可以看到AutoSize有效，並且當它自由運行時，AutoSize不起作用。如果我用一個可見的窗口運行它，並將最後兩行註釋掉，也會發生同樣的情況。因此，看起來PowerPoint在代碼運行時無法刷新內容，並且/或者代碼完成時窗口處於視圖中。我嘗試了各種DoEvents和Sleep（使用WinAPI）的組合，並沒有任何工作。我還注意到，使用睡眠時，窗口出現一張幻燈片，但沒有內容（就像PowerPoint正在等待，直到代碼執行完成才刷新窗口）。所以我一直在想，除非你在關閉文件之前讓你的代碼完成，否則這是行不通的。