Excel / PowerPoint text size after shrink to fit

Question

The main problem is that PowerPoint tables do not have a shrink to fit option.

Since I am using Visual Basic to populate a PowerPoint presentation from Excel, I am able to utilize Excels ability to shrink to fit a cell. The problem is that if I paste the information into PowerPoint it does not use the post shrink to fit font size. The option I am left with at the moment is to use Excels shrink to fit and then paste an image of the cells into PowerPoint, but that eliminates the ability to edit the table at a later time.

If there is a way to get the post shrink to fit font size from Excel then I can populate the PowerPoint and change the font size, but I only know how to get the font size of a cell (which is not updated to reflect shrink to fit).

Anything that could be used to shrink to fit a PowerPoint table would be helpful.

Edit: While typing up the question I thought of a possible workaround, but it does not seem to be working. I tried to make a temporary hidden TextBox, re-size it to the same as the Cell, change the formatting to that of the cell, then enable shrink on overflow for this temporary TextBox. The problem is that when I try to get the text size, it returns the original default for the TextBox.

Function getStringShrinkSize(wid As Double, high As Double, txt As String) As Double
  Set shpCurShape = ActiveWindow.View.Slide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, wid, high)
  shpCurShape.name = "temp1"
  With shpCurShape
    .height = high
    .Width = wid
    With .TextFrame.TextRange
        With .Font
            .Bold = msoTrue
            .name = "Tahoma"
        End With
    End With
    With .TextFrame2
        .WordWrap = True
        .AutoSize = msoAutoSizeTextToFitShape
        .TextRange = txt
    End With
  End With
  getStringShrinkSize = ActiveWindow.View.Slide.Shapes("temp1").TextFrame.TextRange.Font.Size
End Function

Sub testGetStringShrinkSize()
  Debug.Print ("" & getStringShrinkSize(50, 20, "This is a test"))
  Debug.Print ("second try: " & ActiveWindow.View.Slide.Shapes("temp1").TextFrame.TextRange.Font.Size)
  ActiveWindow.View.Slide.Shapes("temp1").Delete
End Sub

Paul B. Paul B. · Accepted Answer · 2012-07-25T10:04:19

It seems to be a timing issue. The macro returns before the reduced font size is applied. If you query the font size later it will be reduced.

I was able to get around this with some sort of busy-wait timer, see code below. Not exactly a pretty solution but if your code runs in batch mode and timing is not an issue it could work for you.

Function getStringShrinkSize(wid As Double, high As Double, txt As String) As Double
  Set shpCurShape = ActiveWindow.View.Slide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, wid, high)
  With shpCurShape
    .Height = high
    .Width = wid
    With .TextFrame.TextRange.Font
            .Bold = msoTrue
            .Name = "Tahoma"
            ' Set known default font size
            .Size = 20
    End With
    With .TextFrame2
        .AutoSize = msoAutoSizeTextToFitShape
        .WordWrap = True
        .TextRange = txt
    End With
  End With

  ' Wait until the reduced text size is applied but no longer than 3 seconds
  Dim start As Date
  start = Now
  Do
    DoEvents
  Loop Until shpCurShape.TextFrame2.TextRange.Font.Size <> 20 Or DateDiff("s", start, Now) >= 3

  getStringShrinkSize = shpCurShape.TextFrame2.TextRange.Font.Size

End Function

Excel / PowerPoint text size after shrink to fit

1 Answers