如何更改 Powerpoint VBA Macro 中的字体（字符）间距

Question

我有这个宏用于更改文本。虽然我也想将此处的字符间距更改为“压缩”0.5。这可能吗？

Sub FormatText()
    Dim slide As slide
    Dim shape As shape
    Dim textRange As textRange
    
    ' Loop through each slide starting from the second slide
    For Each slide In ActivePresentation.Slides
        If slide.SlideIndex > 1 Then
            ' Loop through each shape in the slide
            For Each shape In slide.Shapes
                If shape.HasTextFrame Then
                    If shape.TextFrame.HasText Then
                        For Each textRange In shape.TextFrame.textRange.Paragraphs
                            If textRange.Font.Size = 70 Or textRange.Font.Size = 72 Then
                                ' Apply formatting
                                textRange.Font.Size = 72
                                textRange.ParagraphFormat.SpaceWithin = 0.85
                            End If
                        Next textRange
                    End If
                End If
            Next shape
        End If
    Next slide
End Sub

我尝试过，但没有成功：

TextRange.Font.Spacing = 1

Answer 1

这是修改后的宏（也发布在answers.microsoft.com 上）。变量已重命名为更可靠（Dim shape，因为形状可能会混淆 VBA），并且 TextRange2 引用 TextFrame2 对象，因此 Spacing 属性可用。

Sub FormatText()
    Dim oSlide As slide
    Dim oShape As shape
    Dim oTextRange As TextRange2

    ' Loop through each slide starting from the second slide
    For Each oSlide In ActivePresentation.Slides
        If oSlide.SlideIndex > 1 Then
            ' Loop through each shape in the slide
            For Each oShape In oSlide.Shapes
                If oShape.HasTextFrame Then
                    If oShape.TextFrame.HasText Then
                        For Each oTextRange In oShape.TextFrame2.textRange
                            If oTextRange.Font.Size = 70 Or oTextRange.Font.Size = 72 Then
                                ' Apply formatting
                                oTextRange.Font.Size = 72
                                oTextRange.Font.Spacing = oTextRange.Font.Spacing - 0.5
                            End If
                        Next oTextRange
                    End If
                End If
            Next oShape
        End If
    Next oSlide
End Sub