Question

主要问题是PowerPoint表没有缩小以适应选项。

由于我使用Visual Basic从Excel填充PowerPoint演示文稿，因此我能够利用Excels缩小以适合单元格。问题是，如果我将信息粘贴到PowerPoint中，它不会使用post shrink来适应字体大小。我目前留下的选项是使用Excel缩小以适合然后将单元格的图像粘贴到PowerPoint中，但这样就无法在以后编辑表格。

如果有办法让帖子缩小以适应Excel中的字体大小，那么我可以填充PowerPoint并更改字体大小，但我只知道如何获取单元格的字体大小（未更新为反映缩小以适应）。

任何可用于缩小以适合PowerPoint表的内容都会有所帮助。

编辑：在输入问题时我想到了可能的解决方法，但它似乎没有起作用。我尝试制作一个临时隐藏的TextBox，将其重新调整为与Cell相同，将格式更改为单元格，然后为此临时TextBox启用溢出收缩。问题是，当我尝试获取文本大小时，它返回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

Answer 1

这似乎是一个时间问题。宏在应用缩小字体大小之前返回。如果您稍后查询字体大小，它将被缩小。

我能够通过某种忙等待计时器解决这个问题，请参阅下面的代码。这不是一个非常漂亮的解决方案，但如果您的代码以批处理模式运行并且时间不是问题，那么它可能适合您。

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文本大小

1 个答案: