如何使用 vba 更改 powerpoint 中特定单词的间距？

Question

我尝试做的是在 vba 中编写一个遍历所有文本/形状框的子程序，使用“间距”方法在单词中查找特定单词/字符并更改它们之间的空格。 出于某种原因，我不断收到同样的错误，我不知道如何解决。 例如，假设我有一个字符串 RLgsfub，并且我有一个单词列表 (RF,gs,Fg)。 子将找到 gs 并更改间距。

我尝试将一些东西结合起来，但我不明白为什么它仍然不起作用。 这是最后一个代码，当将其设置为 .Font.Bold = true 时，它可以工作，但在 .Font2.spacing = 2 的情况下它不起作用。 我尝试将 shp.TextFrame.TextRange 更改为 shp.TextFrame2.TextRange 但仍然无法正常工作。

Sub spacing():
For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(FindWhat:="CompanyX")
            Do While Not (foundText Is Nothing)
                With foundText
                    .Font2.spacing = 0
                    Set foundText = _
                        txtRng.Find(FindWhat:="CompanyX", _
                        After:=.Start + .Length - 1)
                End With
            Loop
        End If
    Next
Next
End Sub

我尝试使用的其他代码：

这个工作正常：

Sub use()

Dim s As Slide
Dim shp As Shape


For Each s In ActivePresentation.Slides

    For Each shp In s.Shapes
        If shp.HasTextFrame Then
            With shp
            .TextFrame2.TextRange.Font.spacing = 24
        End If
    Next shp

Next s
End Sub

这个不行：

Sub HighlightKeywords()
    Dim sld As Slide
    Dim shp As Shape
    Dim txtRng As TextRange, rngFound As TextRange2
    Dim i As Long, n As Long
    Dim TargetList

    '~~>  Array of terms to search for
    TargetList = Array("keyword", "second", "third", "etc")

    '~~> Loop through each slide
    For Each sld In Application.ActivePresentation.Slides
        '~~> Loop through each shape
        For Each shp In sld.Shapes
            '~~> Check if it has text
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame2.TextRange

                For i = 0 To UBound(TargetList)
                    '~~> Find the text
                    Set rngFound = txtRng.Find(TargetList(i))

                    '~~~> If found
                    Do While Not rngFound Is Nothing
                        '~~> Set the marker so that the next find starts from here
                        n = rngFound.Start + 1
                        '~~> Chnage attributes
                        With rngFound.Font
                        .spacing = -24
                            '~~> Find Next instance
                            Set rngFound = txtRng.Find(TargetList(i), n)
                        End With
                    Loop
                Next
            End If
        Next
    Next
End Sub

谢谢！

Answer 1

您最后的代码有几个缺陷，但问题是没有设置间距。 txtRng 应该是 TextRange2 类型，间距应该不是负数（虽然这样可行），但主要问题是它在搜索单词时会陷入死循环。

我已经拆分了您的代码并更改了如何在形状中找到单词的逻辑：我将文本复制到字符串变量中以搜索单词，使用命中来格式化形状文本并替换找到的单词在复制的字符串中由一个假人所以很容易找到下一个出现的单词。

调用例程的内部循环可以简化为

        If shp.HasTextFrame Then
            For i = 0 To UBound(TargetList)
                Call MarkCharacters(shp.TextFrame2.TextRange, CStr(TargetList(i)))
            Next
        End If

新的子看起来像

Sub MarkCharacters(txtRng As TextRange2, word As String)

    Dim s As String, wordPos As Long, wordLen As Long
    s = txtRng.Text
    wordLen = Len(word)

    wordPos = InStr(s, word)
    Do While wordPos > 0
        DoEvents
        txtRng.Characters(p, wordLen).Font.Spacing = 24
        ' Replace found word with "x"
        s = Left(s, wordPos - 1) _
          & String(wordLen, "x") _
          & Mid(s, wordPos + l)
        wordPos = InStr(s, word)
    Loop
End Sub

Answer 2

所以最终，这对我有用： （我混合了几个想法，不确定它是否以最好和最短的方式编写 - 但它有效:)

  Dim sld As Slide
Dim shp As Shape
Dim txtRng As TextRange, rngFound As TextRange2
Dim j As Long, n As Long
Dim TargetList

'~~>  Array of terms to search for
TargetList = Array("Uf", "uf", "nU", "Nu", "Bf", "NuF", "nH", "Nh", "bF", "nUf", "Jk", "jK")

'~~> Loop through each slide
For Each sld In Application.ActivePresentation.Slides
    '~~> Loop through each word
        For j = 0 To UBound(TargetList)
            Call changeFont(CStr(TargetList(j)))
        Next
Next

还有第二部分：

Sub changeFont(word As String)

Dim oPresentation   As Presentation
Dim oSlide          As Slide
Dim oShape          As Shape
Dim stringSearched  As String
Dim wordPos As Long
Dim wordLen As Long

stringSearched = word
wordLen = Len(stringSearched)

'all opened presentations
For Each oPresentation In Presentations
    'all slide in them
    For Each oSlide In oPresentation.Slides
        'all shapes (anything)
        For Each oShape In oSlide.Shapes
            'only those that contain text
            If oShape.HasTextFrame Then
                wordPos = InStr(oShape.TextFrame.TextRange.Text, stringSearched)
                If wordPos > 0 Then
                    'here you need to define where the text ends and start
                    oShape.TextFrame2.TextRange.Characters(InStr(oShape.TextFrame.TextRange.Text, stringSearched), Len(stringSearched)).Font.Spacing = -5
                End If
            End If
        Next
    Next
Next
End Sub