2

我使用这个站点的一些代码制作了一个宏来对 Word 文档进行关键字搜索并突出显示结果。

我想在 PowerPoint 中复制效果。

这是我的 Word 代码。

Sub HighlightKeywords()

Dim range As range
Dim i As Long
Dim TargetList

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

For i = 0 To UBound(TargetList) ' for the length of the array

   Set range = ActiveDocument.range

   With range.Find ' find text withing the range "active document"
   .Text = TargetList(i) ' that has the words from the array TargetList
   .Format = True ' with the same format
   .MatchCase = False ' and is case insensitive
   .MatchWholeWord = True ' and is not part of a larger word
   .MatchAllWordForms = False ' and DO NOT search for all permutations of the word

   Do While .Execute(Forward:=True)
   range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow

   Loop

   End With
Next

End Sub

这是我目前在 PowerPoint 中的内容，它绝不是功能性的。

Sub HighlightKeywords()

Dim range As range
Dim i As Long
Dim TargetList

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

For Each sld In Application.ActivePresentation.Slides

For Each shp In sld.Shapes

    If shp.HasTextFrame Then

        Set txtRng = shp.TextFrame.TextRange

For i = 0 To UBound(TargetList) ' for the length of the array

   With range.txtRng ' find text withing the range "shape, text frame, text range"
   .Text = TargetList(i) ' that has the words from the array TargetList
   .Format = True ' with the same format
   .MatchCase = False ' and is case insensitive
   .MatchWholeWord = True ' and is not part of a larger word
   .MatchAllWordForms = False ' and DO NOT search for all permutations of the word

   Do While .Execute(Forward:=True)
   range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow

   Loop

   End With
Next

End Sub

我最终通过 MSDN 找到了我的答案，但它与我从人们提交的内容中选择的正确答案非常接近。

这是我使用的代码：

Sub Keywords()

Dim TargetList
Dim element As Variant

TargetList = Array("First", "Second", "Third", "Etc")

For Each element In TargetList
   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:=element, MatchCase:=False, WholeWords:=True)
            Do While Not (foundText Is Nothing)
               With foundText
                  .Font.Bold = True
                  .Font.Color.RGB = RGB(255, 0, 0)
               End With
            Loop
         End If
      Next
   Next
Next element

End Sub

事实证明，代码有效，但却是一场性能噩梦。我在下面选择作为正确答案的代码运行得更加顺畅。我已经调整了我的程序以匹配所选的答案。

4

3 回答 3

2

AFAIK 没有内置方法可以用颜色突出显示找到的单词。您可以特意创建一个矩形并将其放在找到的文本后面并为其着色，但这完全是一个不同的球类游戏。

这是一个示例，它将在所有幻灯片中搜索文本，然后将找到的文本设为粗体、下划线和斜体。如果你愿意，你也可以改变字体的颜色。

假设我们有一张看起来像这样的幻灯片

在此处输入图像描述

将此代码粘贴到模块中，然后尝试。我已经对代码进行了注释，以便您理解它不会有问题。

Option Explicit

Sub HighlightKeywords()
    Dim sld As Slide
    Dim shp As Shape
    Dim txtRng As TextRange, rngFound As TextRange
    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.TextFrame.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
                            .Bold = msoTrue
                            .Underline = msoTrue
                            .Italic = msoTrue
                            '~~> Find Next instance
                            Set rngFound = txtRng.Find(TargetList(i), n)
                        End With
                    Loop
                Next
            End If
        Next
    Next
End Sub

最终截图

在此处输入图像描述

于 2013-04-06T06:26:33.457 回答
1

我想扩展@Siddharth Rout 的答案，这个答案很好而且相当推荐（我的获奖者+1）。但是，也有可能在 PP 中“突出显示”一个单词（单词范围）。设置高亮有一个严重的缺点——它会破坏其他字体设置。因此，如果真的需要使用高亮，我们需要在之后返回适当的字体设置。

这是单个文本框中单个单词的示例：

Sub Highlight_Word()

Dim startSize, startFont, startColor

With ActivePresentation.Slides(1).Shapes(1).TextFrame2.TextRange.Words(8).Font
'read current state
   startSize = .Size
   startFont = .Name
   startColor = .Fill.ForeColor.RGB

'set highlight
   .Highlight.RGB = RGB(223, 223, 223) 'light grey

'return standard parameters
   .Size = startSize
   .Name = startFont
   .Fill.ForeColor.RGB = startColor

End With

End Sub

这种解决方案可以放在@Siddharth 解决方案内部的某个地方。

于 2013-04-06T09:55:38.950 回答
0

如果您需要完全保留原始文本格式，您可以：

在找到包含目标文本的形状时，复制形状 将副本发送到原始形状的 Z 顺序 在副本形状上突出显示 将标签应用于副本和原始，以表明它们稍后需要注意，例如 oOriginalShape.Tags。添加“Hilighting”、“Original” oDupeShape.Tags。添加“Hilighting”、“Duplicate”

将原始形状设置为不可见

然后，如果您需要反转突出显示并恢复原始格式，您只需遍历所有形状；如果形状有一个 Hilighting 标签 = "Original"，让它可见。如果它有 Higlighting tag = "Duplicate"，请将其删除。

这里的问题是，如果有人编辑了突出显示的形状，则在您恢复时编辑将丢失。必须教用户还原、编辑，然后重新=突出显示。

于 2013-04-06T16:14:32.803 回答