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

私の知る限り、見つかった単語を色で強調表示する組み込みの方法はありません。わざわざ長方形を作成し、見つかったテキストの後ろに配置して色を付けることができますが、それはまったく別の球技です。

すべてのスライドでテキストを検索し、見つかったテキストを太字、下線、斜体にする例を次に示します。必要に応じて、フォントの色を変更することもできます。

このようなスライドがあるとしましょう

ここに画像の説明を入力

このコードをモジュールに貼り付けて、試してみてください。コードを理解するのに問題がないように、コードにコメントを付けました。

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 では単語 (単語の範囲) を「強調表示」することもできます。ハイライトを設定することには重大な欠点が 1 つあります。それは、他のフォント設定を破壊することです。したがって、本当にハイライトを使用する必要がある場合は、後で適切なフォント設定を返す必要があります。

以下は、1 つのテキスト フレーム内の 1 つの単語の例です。

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.Add "Hilighting"、"Duplicate" を追加

元の形状を非表示に設定

次に、強調表示を逆にして元の書式を復元する必要がある場合は、すべての図形をループするだけです。シェイプに Hilighting タグ = "Original" がある場合は、それを表示します。Hilighting tag = "Duplicate" の場合は削除してください。

ここでの問題は、誰かがハイライトされた形状を編集した場合、元に戻すと編集内容が失われることです。ユーザーは、元に戻し、編集し、次に再 = ハイライトするように教える必要があります。

于 2013-04-06T16:14:32.803 に答える