vba - 缩小后的 Excel/PowerPoint 文本大小

Question

主要问题是 PowerPoint 表格没有“缩小以适合”选项。

由于我使用 Visual Basic 从 Excel 填充 PowerPoint 演示文稿，因此我能够利用 Excel 缩小以适合单元格的功能。问题是，如果我将信息粘贴到 PowerPoint 中，它不会使用后期缩小来适应字体大小。我目前剩下的选择是使用 Excel 缩小以适应单元格图像，然后将单元格图像粘贴到 PowerPoint 中，但这消除了以后编辑表格的能力。

如果有一种方法可以让帖子缩小以适应 Excel 中的字体大小，那么我可以填充 PowerPoint 并更改字体大小，但我只知道如何获取单元格的字体大小(不会更新为反射(reflect)收缩以适应)。

任何可以用来缩小以适合 PowerPoint 表格的东西都会很有帮助。

编辑:在输入问题时，我想到了一个可能的解决方法，但它似乎不起作用。我尝试制作一个临时隐藏的文本框，将其大小重新调整为与单元格相同，将格式更改为单元格的格式，然后为此临时文本框启用溢出收缩。问题是，当我尝试获取文本大小时，它返回文本框的原始默认值。

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