1

Тема: Макрос для работы с тезаурусом

Коллеги, есть идея написать макрос, который заменяет каждое слово русского текста первым (или случайным) словом из русского же тезауруса.
Это было бы полезно для студентов. Предполагаю, что после такого изменения и последующей ручной корректировки тексты будут прекрасно проходить антиплагиатный контроль.
Кто-нибудь знает, как с помощью макроса обратиться к коллекции тезауруса (например, в Word 2010)?

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

2

Re: Макрос для работы с тезаурусом

I. Для выполнения макроса нужна конкретная задача и алгоритм.
II. По поводу доступа к тезаурусу.

Общий доступ осуществляется через объект SynonymInfo например:
1. Создайте новый документ, наберите слово Планировать, выделите его или поставьте на нём курсор. Нажмите кнопку Тезаурус и у Вас появиться окно тезауруса. Оно нам понадобиться для сравнения.
2. В окне тезауруса мы видим, что у слова Планировать есть два основных синонима:
    - Намереваться и родственные ему слова;
    - Намечать и родственные ему слова.
Доступ к этим словам осуществляется через список свойства SynonymInfo.MeaningList вот функция возвращающая список:

Public Function SynonymList() As Variant
    SynonymList = SynonymInfo(Trim(Selection.Words(1).Text)).MeaningList
End Function

Выражение Trim(Selection.Words(1).Text) возвращает текстовое значение 1-го слова выделения без пробелов.
В результате выполнения функции мы получаем результат:
SynonymList(1) = Намереваться
SynonymList(2) = Намечать
3. Теперь чтобы получить доступ к родственным словам каждого синонима нам надо воспользоваться свойством SynonymInfo.SynonymList для этого напишем функцию создающую список синонимов каждого слова из списка SynonymList:

Public Function SubSynonymList(SL As Variant, w As Integer) As Variant
Dim s As String
    s = SL(w)
    SubSynonymList = SynonymInfo(s).SynonymList(w)
End Function

SubSynonymList имеет 2 обязательных аргумента:
SL это наша функция SynonymList;
w это номер массива SynonymList
4. Имея эти 2-е функции SynonymList и SubSynonymList уже можно писать более сложные процедуры. Вот например процедура тестирующая наши функции:
Данная процедура выводит на экран информацию о выделенном слове Планировать, его первом синониме Намереваться и родственных ему словах:

Public Sub Test_Thesaurus()
Dim info As String, s As String, sn As String, subsn As String
    If UBound(SynonymList) > 0 Then
        s = Trim(Selection.Words(1).Text)
        sn = SynonymList(1)
        subsn = Join(SubSynonymList(SynonymList, 1), Chr(13))
    End If
    info = "Слово: " & s & Chr(13)
    info = info & "Синоним 1: " & sn & Chr(13)
    info = info & "Родственные слова:" & Chr(13)
    info = info & subsn
    MsgBox info
End Sub

5. Вот общий код модуля:

Public Function SynonymList() As Variant
    SynonymList = SynonymInfo(Trim(Selection.Words(1).Text)).MeaningList
End Function

Public Function SubSynonymList(SL As Variant, w As Integer) As Variant
Dim s As String
    s = SL(w)
    SubSynonymList = SynonymInfo(s).SynonymList(w)
End Function

Public Sub Test_Thesaurus()
Dim info As String, s As String, sn As String, subsn As String
    If UBound(SynonymList) > 0 Then
        s = Trim(Selection.Words(1).Text)
        sn = SynonymList(1)
        subsn = Join(SubSynonymList(SynonymList, 1), Chr(13))
    End If
    info = "Слово: " & s & Chr(13)
    info = info & "Синоним 1: " & sn & Chr(13)
    info = info & "Родственные слова:" & Chr(13)
    info = info & subsn
    MsgBox info
End Sub

Вот вкратце ответ. Если есть вопросы или что непонятно пишите

3

Re: Макрос для работы с тезаурусом

Большое спасибо, Александр, за подробный ответ! smile
Теперь осталось только перебрать все слова текста и заменить каждое слово, имеющее синоним, на предлагающийся программой первый синоним.
Был бы признателен, если бы вы привели основную канву для такого перебора и замены.

И еще это нужно сделать только для русских слов! roll

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

4

Re: Макрос для работы с тезаурусом

Перебор всех слов в документе у меня получился так:

Sub AllWords()
    Dim Wrd As String
    Dim i As Integer
    Set myWord = ActiveDocument.Words
    For i = 1 To ActiveDocument.Words.Count
        Wrd = myWord(i).Text
        MsgBox Wrd
    Next i
End Sub

Однако, словами считаются и точки, и запятые, и кавычки, и слова, записанные латиницей.
Не посоветуете ли, как отобрать только слова, записанные кириллицей?

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

5

Re: Макрос для работы с тезаурусом

Вот во вложенном файле в модуле ThisDocument макрос RussSynonym показывающий общее направление перебора и замены. Но есть нюансы.
1. Если не поставить в коде On Error Resume Next как у меня, макрос будет выдавать ошибку "Недостаточно памяти".
2. Структура Word такова, что обращаясь к ActiveDocument.Words Вы сможете перебрать все слова, если у Вас в документе нет других элементов, например Надпись, Сноска, Колонтитул и пр.
3. Тезаурус некоторых слов может меняться после замены слова и не возвращать исходное значение, поэтому надо предусмотреть возможность точного запоминания замены и возврата, например через объект Variable.
Жду вопросов!!! smile

Post's attachments

Не ведаю как и произнести.doc 32.5 Кб, 5 скачиваний с 2012-10-09 

You don't have the permssions to download the attachments of this post.

6

Re: Макрос для работы с тезаурусом

Супер! То, что надо!
Выкладываю на всеобщее обозрение макрос, созданный Александром (я только закомментировал одну строку, где производится выделение цветом):

Public Sub RussSynonym()
Dim w As Range, col As Collection, bm As Bookmark
    Set col = New Collection
    For Each w In ActiveDocument.Words
        If w.LanguageID = wdRussian Then
            On Error Resume Next
                If UBound(w.SynonymInfo.MeaningList) > 0 Then
                    i = i + 1
                    If w.Characters.Last = Chr(32) Or w.Characters.Last = Chr(160) Then
                        Set s = ActiveDocument.Range(w.Start, w.End - 1)
                        col.Add s
                    Else
                        col.Add w
                    End If
                End If
        End If
    Next w
        For i = 1 To col.Count
                Set w = col(i)
                    w.Text = w.SynonymInfo.MeaningList(1)
'                    w.HighlightColorIndex = wdPink
        Next i
End Sub

Что касается загрузки памяти при больших объемах, то можно применять эту процедуру к отдельным частям текста.
При необходимости можно сделать и так, чтобы пользователь мог согласиться с заменой или отказаться от нее.

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

7

Re: Макрос для работы с тезаурусом

1. В данном случае процедура относиться только к словам, которые Word видит в объекте ActiveDocument.Words
2. Для точной обратной замены макрос не корректен. Поэтому должен проводиться только 1 раз. Я написал его чтобы показать общую концепцию.

8

Re: Макрос для работы с тезаурусом

Обратная замена обычно и не нужна. smile

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

9

Re: Макрос для работы с тезаурусом

Хорошо, а Надписи, Колонтитулы, Сноски. Макрос надо доработать.

10

Re: Макрос для работы с тезаурусом

Немного изменил для изменения выделенного фрагмента. Также теперь программа спрашивает, нужно заменять слово или нет:

Public Sub RussSynonymSelection()
' Для выделенного фрагмента
Dim w As Range, col As Collection, bm As Bookmark
Dim Reply As Integer
    If Selection.Words.Count = 1 Then
        Reply = MsgBox("Нужно выделить отрывок для замены. Продолжить?", vbYesNo)
'       Yes - 6, No - 7
        Select Case Reply
'        Case 6 ' Yes
'
        Case 7  ' No
            Exit Sub
        End Select
    End If
    Set col = New Collection
    For Each w In Selection.Words
        If w.LanguageID = wdRussian Then
            On Error Resume Next
                If UBound(w.SynonymInfo.MeaningList) > 0 Then
                    i = i + 1
                    If w.Characters.Last = Chr(32) Or w.Characters.Last = Chr(160) Then
                        Set s = ActiveDocument.Range(w.Start, w.End - 1)
                        col.Add s
                    Else
                        col.Add w
                    End If
                End If
        End If
    Next w
    For i = 1 To col.Count
        Set w = col(i)
        Selection.MoveLeft Unit:=wdWord, Count:=1
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = w.Text
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
        End With
        Selection.Find.Execute
        Reply = MsgBox("Заменить '" & w.Text & "' на '" & w.SynonymInfo.MeaningList(1) & "'?", vbYesNoCancel)
'           Yes - 6, No - 7, Cancel - 2
        Select Case Reply
        Case 6 ' Yes
            w.Text = w.SynonymInfo.MeaningList(1)
'       Case 7
'
        Case 2 ' Cancel
            Exit For
        End Select
    Next i
End Sub
Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

11

Re: Макрос для работы с тезаурусом

Хорошо. Вот уже творческая мысль заработала smile . При замене текста в Надписях эта строка

Set s = ActiveDocument.Range(w.Start, w.End - 1)

даст сбой.  big_smile

12

Re: Макрос для работы с тезаурусом

aap77 пишет:

Хорошо. Вот уже творческая мысль заработала smile . При замене текста в Надписях эта строка

Set s = ActiveDocument.Range(w.Start, w.End - 1)

даст сбой.  big_smile

Если используется замена текста в выделении, то это не страшно. sad

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

13

Re: Макрос для работы с тезаурусом

Если используется замена текста в выделении, то это не страшно.

Как раз это и страшно.
Номер знака в Надписи и в Активном документе это 2-а разных параметра.
И программное обращение к ним требует разных подходов.

14

Re: Макрос для работы с тезаурусом

aap77 пишет:

Если используется замена текста в выделении, то это не страшно.

Как раз это и страшно.
Номер знака в Надписи и в Активном документе это 2-а разных параметра.
И программное обращение к ним требует разных подходов.

Я имею в виду, что пользователь может не выделять Надпись, если ему об этом сказать.
Кроме того, я предполагаю, что, если и будет выделена Надпись, то с ней, скорее всего, ничего не произойдет, и она не "испортится". Разве не так?

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

15

Re: Макрос для работы с тезаурусом

Да макрос ее вообще не воспримет, пропустит! А если такую же замену надо произвести в Надписи? Она же тоже является частью документа. Здесь для большинства пользователей, как и продвинутых пользователей объекты Range и Selection являются камнем предкновения. Я эти проблемы обозначил сразу в этой теме, дав общее направление алгоритма поставленной задачи.