动态的Excel VBA代码来改变文本框大小

Question

现在，我正在努力的“PowerPoint演示文稿幻灯片”从Excel数据自动化。按要求，我必须创建一个“动态代码”但是它可以更新的幻灯片“标题”，牢记的是，如果文本是足够大，那么盒子的“高度”应双倍和“布局“盒子应该改变。

按我的理解，我尝试了文本的“长度”的逻辑，然后更改相应的盒子“高度”和“布局”。

从我的Excel VBA代码摘录

Dim powApp As PowerPoint.Application
Dim powPres As PowerPoint.Presentation
Dim powSlide As PowerPoint.Slide

Set powApp = New PowerPoint.Application
Set powSlide = powPres.Slides(2)
Set powShape = powSlide.Shapes(3)

'cell W7 contains the length of the text of the Title
    If Sheets("sht1").Range("W7").Value > 45 Then
        With powShape
        .Top = 13
        .Height = 57.5
        End With
    ElseIf Sheets("sht1").Range("W7").Value <= 45 Then
        With powShape
        .Top = 20
        .Height = 32
        End With
    End If

但与此代码的问题是，如果我们有这样的字符（标题文本），但是这需要更多的空间，不增加长度例如“M”或“W”（和反之亦然的字符“I”或“T”等）。的多个这些字符存在转移到下一行自动。

EG

1. 在2016年的销售数字ITMS％具有> 50％
2. 在2016年的销售数字WMSWX％具有> 50％

理想的情况是1和2都应该是在标题的一条线，因为它们都已经len个<45但由于W，M，W和X需要更多的空间第二文本被自动转移到下一行，但框的高度和位置不。

所以，我的代码是不是完全动态的或自动:(

今后，可以请你建议，通过它的高度和位置更适当地改变代码

Answer 1

有测量文本框的宽度的方式 - 这是不一样的东西作为测量的文本串的宽度。我已经在过去做的是创建一个临时文本框，在所需的字体文本填充它，并测量的宽度。这里是你可以用它来满足您的需要一些示例代码。

基于文本框的宽度，包括你的文字，你可以在你的代码调整框的大小。

Option Explicit

Sub test()
    Dim width As Long
    width = MeasureTextFrame("Here Is My Test Title Which Might be Really Long", isBold:=True)
    Debug.Print "text box width is " & width
    width = MeasureTextFrame("Here Is Another Title That's Shorter", isBold:=True)
    Debug.Print "text box width is " & width
End Sub

Public Function MeasureTextFrame(ByVal inputText As String, _
                                 Optional ByVal thisFont As String = "Arial", _
                                 Optional ByVal thisSize As Long = 14, _
                                 Optional ByVal isBold As Boolean = False) As Double
    Dim thisPPTX As Presentation
    Set thisPPTX = ActivePresentation

    '--- create a temporary slide for our measurements
    Dim thisSlide As Slide
    Dim thisLayout As CustomLayout
    Set thisLayout = thisPPTX.Slides(1).CustomLayout
    Set thisSlide = thisPPTX.Slides.AddSlide(thisPPTX.Slides.Count + 1, thisLayout)

    Dim thisFrame As TextFrame
    Set thisFrame = thisSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, 100, 100).TextFrame
    With thisFrame
        .WordWrap = msoFalse
        .AutoSize = ppAutoSizeShapeToFitText
        .TextRange.Text = inputText
        .TextRange.Font.Name = thisFont
        .TextRange.Font.Size = thisSize
        .TextRange.Font.Bold = isBold
    End With

    '--- return width is in points
    MeasureTextFrame = thisFrame.Parent.width

    '--- now delete the temporary slide and frame
    thisSlide.Delete
End Function