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

Question

我尝试做的是在 vba 中编写一个遍历所有文本/形状框的子项，查找单词中的特定单词/字符并更改 space 之间，使用 'spacing'方法。出于某种原因，我不断收到同样的错误，我不知道如何解决。例如，假设我有一个字符串 RLgsfub，并且我有一个单词列表 (RF,gs,Fg)。 sub 将找到 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

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

How can I change the spacing for specific words in powerpoint, using vba?

powerpoint

vba

spacing