使文本适合形状

Question

我正在使用 PowerPoint VBA 进行编码，并尝试将文本放置在矩形内，但要确保文本适合（因此不会溢出）。我不想调整形状本身的大小，而是调整文本的大小。

我看到可以用了

oShp.TextFrame2.AutoSize = msoAutoSizeTextToFitShape

但是，这样做的问题是，当 PowerPoint 处于正常模式时，只有在用户单击文本框后，文本才会调整大小。当 PowerPoint 为运行!

时，我需要此功能

我很想知道是否有办法让文本自动调整大小，或者我是否需要寻找替代方法？

感谢您的宝贵意见！

Answer 1

在形状格式中，在文本选项下，选择溢出时缩小文本的选项。

然后，使用 .Shapes("Title 1").TextFrame.TextRange 我们通过 VBA 输入文本。

文本会自动更改其字体大小。

Answer 2

我想我会回答我的问题并关闭线程。经过大量研究后，我发现没有明显的方法可以让文本在 PowerPoint 放映运行时自动调整自身大小。我尝试了多种方法，例如插入文本、修剪文本以及关闭和打开自动换行 - 然而，其中 none 行得通。我注意到 (Bhavesh) 我完全了解如何通过 PowerPoint 的 GUI select 自动调整文本大小设置。

最后我的解决方案是做一个 do 循环并更改文本的大小。

下面我粘贴了我的关键行，希望它能帮助其他正在尝试做同样事情的人。我做了一个变量溢出，它试图评估形状文本框的高度是否大于矩形的大小。

Dim overflow As Integer
Dim counter As Integer    

counter = 0

With ActivePresentation.Slides(i).Shapes(stringToTest)
                    
overflow = CInt((.TextFrame.TextRange.BoundHeight) - (.Height - .TextFrame.MarginTop - .TextFrame.MarginBottom))
                    
Do While overflow > 16 And counter < 50
'*** I note that the shape is overflowing when its value is >0 but I found 16 to be the most "aesthetically pleasing" number!
'*** Also using a counter prevents the code from potentially getting stuck in an infinite loop

If .TextFrame.TextRange.Font.Size > 20 Then                                
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size - 1
Else
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size - 0.5
End If
'**** By reducing the font size by 0.5 this provided a better fit for the text _
'**** (even better than using on PowerPoint's auto-size function!)

counter = counter + 1
overflow = CInt((.TextFrame.TextRange.BoundHeight) - (.Height - .TextFrame.MarginTop - .TextFrame.MarginBottom))
Loop

End With

使文本适合形状

Getting Text To Fit A Shape

powerpoint

vba

text