Search code examples
vbatextpowerpoint

Getting Text To Fit A Shape


I am coding using PowerPoint VBA and am trying to place text inside a rectangle shape, but ensure that the text fits (so there is no overflowing). I do not want the shape itself to resize, but the text to resize.

I have seen that I can use

oShp.TextFrame2.AutoSize = msoAutoSizeTextToFitShape

However, the problem with this is that the text will only resize after the user has clicked on the textbox when PowerPoint is in normal mode. I want this functionality when the PowerPoint is running!

I would be grateful to know is there a way to get the text automatically resized or do I need to find an alternative method?

Thank you for any comments!


Solution

  • I thought I would answer my question and close the thread. After doing much research I found that there was no apparent method to get the text to auto-resize itself when the PowerPoint Show runs. I tried a number of approaches e.g. inserting text, trimming the text and turning word wrap off and on - however, none of these worked. I note (Bhavesh) I was fully aware of how to select the auto-size text settings via PowerPoint's GUI.

    In the end my solution was to make a do loop and change the size of the text.

    Below I pasted my key lines in the hope that it might help someone else who is trying to do the same. I made a variable overflow which attempts to assess if the height of the shape's textbox is bigger than the size of the rectangle.

    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