Vba PowerPoint形状导出恒定图像尺寸

我正在尝试将PPT形状导出到图像文件中，但是PowerPoint正在根据文本长度重新调整形状的大小

我知道VBA中有一个自动调整大小功能，但是我无法在PowerPoint 2013中使用MSOAutoSizeTextToFape功能

我的代码如下

Sub RunMe()
    Dim MyShape As Shape
    Dim i As Integer
    Dim S(0 To 2) As String

    Set MyShape = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 40)
    S(0) = "short text"
    S(1) = "Medium length text"
    S(2) = "Really Really Long and descriptive Text"
        For i = 0 To 2
            With MyShape
                '.TextFrame.AutoSize = PowerPoint.ppAutoSizeMixed
                .TextFrame.TextRange.Text = S(i)
                .Export "C:\temp\" & "\" & S(i) & ".png", ppShapeFormatPNG
            End With
        Next i
End Sub

---

正如您将看到的，生成的图像尺寸是不同的。有没有办法创建相同大小的图像？

我在当前电脑上安装了2003版，因此未测试以下内容

根据一些网站的说法，TextFrame2从2007年起就是一个新的属性

您可以在TextFrame2上尝试MSOAutoSizeTextToFape

编辑：

我用2010版在家里的电脑上试过了，看起来还不错。试试看。

---

将代码中的TextFrame替换为TextFrame2

您可以调整文本大小以确保其符合形状，也可以调整形状以符合文本大小。我猜你会想要前者，所以试试这个：

Sub RunMe()
    Dim MyShape As Shape
    Dim i As Integer
    Dim S(0 To 2) As String
    Dim sngOriginalSize As Single

    Set MyShape = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 40)
    S(0) = "short text"
    S(1) = "Medium length text"
    S(2) = "Really Really Long and descriptive Text"
        For i = 0 To 2
            With MyShape
                .TextFrame.TextRange.Text = S(i)

                ' store original text size
                sngOriginalSize = .TextFrame.TextRange.Font.Size

                ' decrement font size until the text fits
                ' within the shape:
                Do While .TextFrame.TextRange.BoundHeight > MyShape.Height
                    .TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size - 1
                Loop

                .Export "C:\temp\" & "\" & S(i) & ".png", ppShapeFormatPNG

                ' reset the text to original size
                .TextFrame.TextRange.Font.Size = sngOriginalSize
            End With
        Next i
End Sub