Предметный указатель на основании выделения цветом

[Serbel]

Добрый день!
Имеется полностью подготовленный в Ворде макет книги, где автором задумано несколько предметных и именных указателей. Слова и словосочетания (несть числа им) по всему тексту выделены тем или иным цветом. Существует ли способ собрать из них указатель, не вводя вручную каждый пункт списка?

Не по теме:
В Индизайне, например, есть скрипт «Create index topics from character styles».

 

[LeonidB]

Не по теме:
Я не большой умелец в макросах для Ворда, но при помощи функции стандартной записи макроса иногда кое-что смастерить получается.

Вот Вам простенький макрос (фразы для указателя - и только они! - в тексте выделены красным):

Sub UkazatelRed()

Dim bookm As String
Dim FlagBookm As Boolean
   
    Selection.HomeKey Unit:=wdStory
    FlagBookm = True
   
Do While FlagBookm
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = wdColorRed
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    If Selection.Find.Found Then
    bookm = Selection.Text
    ActiveWindow.ActivePane.View.ShowAll = True
    ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=bookm, _
        EntryAutoText:=bookm, CrossReference:="", CrossReferenceAutoText:="", BookmarkName:=""
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Else
        FlagBookm = False
    End If
    Loop
   
End Sub

На запрос макроса, продолжить ли поиск с начала, отвечайте "нет".

 

[LeonidB]

Прошу прощения, внёс небольшую добавочку:

Sub UkazatelRed()

Dim bookm As String
Dim FlagBookm As Boolean
   
    Selection.HomeKey Unit:=wdStory
    FlagBookm = True
   
Do While FlagBookm
    Selection.Find.ClearFormatting
    Selection.Find.Font.Color = wdColorRed
    'Selection.Find.Style = ActiveDocument.Styles("Указатель111")
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    If Selection.Find.Found Then
        bookm = Selection.Text
    ActiveWindow.ActivePane.View.ShowAll = True
    ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=bookm, _
        EntryAutoText:=bookm, CrossReference:="", CrossReferenceAutoText:="", BookmarkName:=""
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Else
        FlagBookm = False
    End If
Loop
   
End Sub

 

[Serbel]

Этот сценарий должен работать в Ворд-2003? При вставке в immediate сообщается:

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Invalid in Immediate pane
---------------------------
ОК Справка
---------------------------

 

[LeonidB]

Этот сценарий должен работать в Ворд-2003? При вставке в immediate сообщается:

Не надо использовать immediate. Нажмите Alt-F11 - запустится VBA. Там создайте новый модуль в Normal (в том случае, если там уже нет доступных модулей):



...и скопируйте в этот модуль макрос. Затем запустите его:

 

[LeonidB]

Кстати, для удобства запуска часто используемых макросов можно вынести кнопки на панель вордовской ленты:

 

[LeonidB]

Доработал макрос для любого RGB-цвета текстового выделения.
Сначала задаём выделению нужный цвет в RGB:



Затем вводим эти значения в макрос (Alt-F11):



Запускаем.
К примеру, для красного (который был в первоначальном варианте макроса) ввести надо (255, 0, 0).

Код нового макроса:

Sub Ukazatel_from_TextColor()

Dim RGBValue
Dim bookm As String
Dim FlagBookm As Boolean
 
    Selection.HomeKey Unit:=wdStory
    FlagBookm = True
 
Do While FlagBookm
    Selection.Find.ClearFormatting
    RGBValue = RGB(78, 10, 168)  ' Введите сюда необходимые значения
    Selection.Find.Font.Color = RGBValue
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    If Selection.Find.Found Then
    bookm = Selection.Text
    ActiveWindow.ActivePane.View.ShowAll = True
    ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=bookm, _
        EntryAutoText:=bookm, CrossReference:="", CrossReferenceAutoText:="", BookmarkName:=""
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Else
        FlagBookm = False
    End If
Loop
 
End Sub

Для поиска по текстовому стилю:

Sub Ukazatel_from_TextStyle()

Dim bookm As String
Dim FlagBookm As Boolean
  
    Selection.HomeKey Unit:=wdStory
    FlagBookm = True
  
Do While FlagBookm
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Название стиля")    ' Введите сюда название стиля (кавычки оставить!)
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    If Selection.Find.Found Then
    bookm = Selection.Text
    ActiveWindow.ActivePane.View.ShowAll = True
    ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=bookm, _
        EntryAutoText:=bookm, CrossReference:="", CrossReferenceAutoText:="", BookmarkName:=""
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Else
        FlagBookm = False
    End If
Loop
  
End Sub