Макрос для конвертации старой орфографии в новую

Макрос для конвертации старой орфографии в новую

Кто занимался вычиткой текста в старой орфографии, тот поймет меня. Конвертация в новую представляется необходимым и оправданным решением. С этой целью я написал небольшой макрос, который текст из старой орфографии переводит в новую. Однако, от простого макроса не стоит ждать чудес, возможны неверные срабатывания, а также за бортом остается большое количество слов, написание которых со временем изменилось, например: стратиг и стратег, литтература и литература. Такие слова придется править вручную.
Скопируйте текст макроса и вставьте его в свой normal.dot

Sub КонвертацияИзСтаройОрфографии()

' КонвертацияИзСтаройОрфографии Макрос
' Конвертация старой орфографии в современную.
' Текст должен быть распознан программой Fine Reader, в которой
' для старой орфографии используется шрифт Cabria.
' Макрос ориентирован на использование этого шрифта.

'---------------------------------------------
' Переменные
' Символы означающие конец слова
EndOfWortString = " .,:;!?-)"
'Шипящие
Hiss = "шщч"
'Звонкие
Sonorous = "бвгджзйльнр"
'Глухие
Deaf = "пфкешсхцчщ"
'---------------------------------------------
' Убираем буквы "ять", "i", "фита"

Dim Simv(1 To 6, 1 To 2) As String

' Заменяем букву "ять"
Simv(1, 1) = ChrW(1123)
Simv(1, 2) = "е"
Simv(2, 1) = ChrW(1122)
Simv(2, 2) = "Е"
' Заменяем букву "i"
Simv(3, 1) = ChrW(1110)
Simv(3, 2) = "и"
Simv(4, 1) = ChrW(1030)
Simv(4, 2) = "И"
' Заменяем букву "фита"
Simv(5, 1) = ChrW(1139)
Simv(5, 2) = "ф"
Simv(6, 1) = ChrW(1138)
Simv(6, 2) = "Ф"

For i = 1 To 6
With Selection.Find
.Text = Simv(i, 1)
.Replacement.Text = Simv(i, 2)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
'---------------------------------------------
'Конечная буква Ъ
For i = 1 To Len(EndOfWortString)
With Selection.Find
.Text = "ъ" + Mid(EndOfWortString, i, 1)
.Replacement.Text = Mid(EndOfWortString, i, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
'---------------------------------------------
'Замена окончаний прилагательные и причастия аго (яго) на ого (его)
' возможны неправильные срабатывания
Dim EndS(1 To 2, 1 To 2)
EndS(1, 1) = "аго"
EndS(1, 2) = "ого"
EndS(2, 1) = "яго"
EndS(2, 2) = "его"

For j = 1 To Len(EndOfWortString)
For i = 1 To 2
With Selection.Find
.Text = EndS(i, 1) + Mid(EndOfWortString, j, 1)
.Replacement.Text = EndS(i, 2) + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
' исправим косяки - "его" после шипящих
For k = 1 To Len(Hiss)
For j = 1 To Len(EndOfWortString)
With Selection.Find
.Text = Mid(Hiss, k, 1) + "ого" + Mid(EndOfWortString, j, 1)
.Replacement.Text = Mid(Hiss, k, 1) + "его" + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
'---------------------------------------------
'Замена окончаний - родительный падеж, прилагательные, множественное число, женский род
' ыя (ия) на ые (ие)
For j = 1 To Len(EndOfWortString)
With Selection.Find
.Text = "ыя" + Mid(EndOfWortString, j, 1)
.Replacement.Text = "ые" + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
'окончание ия напрямую не заменяем, будет путаться с существительными :(
'но нам помогут суффикусы прилагательных
' -- ащ, ющ, ш, ск
Dim Suffix(1 To 3)
Suffix(1) = "ш"
Suffix(2) = "щ"
Suffix(3) = "ск"

For j = 1 To Len(EndOfWortString)
For i = 1 To 3
With Selection.Find
.Text = Suffix(i) + "ия" + Mid(EndOfWortString, j, 1)
.Replacement.Text = Suffix(i) + "ие" + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next

'но а теперь проделаем тоже самое, но учтем суффик -ся
For j = 1 To Len(EndOfWortString)
With Selection.Find
.Text = "ыяся" + Mid(EndOfWortString, j, 1)
.Replacement.Text = "ыеся" + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
For j = 1 To Len(EndOfWortString)
With Selection.Find
.Text = "ияся" + Mid(EndOfWortString, j, 1)
.Replacement.Text = "иеся" + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
' сюда же добавим прилагательные оканчивающиеся на ия, но не обработанные выше
Dim Repl(1 To 10, 1 To 2)

Repl(1, 1) = "древния"
Repl(1, 2) = "древние"
Repl(2, 1) = "средния"
Repl(2, 2) = "средние"
Repl(3, 1) = "какия"
Repl(3, 2) = "какие"
Repl(4, 1) = "другия"
Repl(4, 2) = "другие"
Repl(5, 1) = "мелкия"
Repl(5, 2) = "мелкие"
Repl(6, 1) = "многия"
Repl(6, 2) = "многие"
Repl(7, 1) = "последния"
Repl(7, 2) = "последние"
Repl(8, 1) = "высокия"
Repl(8, 2) = "высокие"
Repl(9, 1) = "дальния"
Repl(9, 2) = "дальние"
Repl(10, 1) = "низкия"
Repl(10, 2) = "низкие"

For j = 1 To Len(EndOfWortString)
For i = 1 To 10
With Selection.Find
.Text = Repl(i, 1) + Mid(EndOfWortString, j, 1)
.Replacement.Text = Repl(i, 2) + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
'---------------------------------------------
' Замена местоимений: оне, одне, однех, однемъ, однеми на они, одни, одних, одним, одними;
' написание с учетом того, что яти и твердые знаки уже убраны
' Замена местоимений: ея (нея) - на её (неё).

Dim Pronout(1 To 7, 1 To 2)

Pronout(1, 1) = "оне"
Pronout(1, 2) = "они"
Pronout(2, 1) = "одне"
Pronout(2, 2) = "одни"
Pronout(3, 1) = "однех"
Pronout(3, 2) = "одних"
Pronout(4, 1) = "однем"
Pronout(4, 2) = "одним"
Pronout(5, 1) = "однеми"
Pronout(5, 2) = "одними"
Pronout(6, 1) = "ея"
Pronout(6, 2) = "её"
Pronout(7, 1) = "нея"
Pronout(7, 2) = "неё"

For j = 1 To Len(EndOfWortString)
For i = 1 To 7
With Selection.Find
.Text = " " + Pronout(i, 1) + Mid(EndOfWortString, j, 1)
.Replacement.Text = " " + Pronout(i, 2) + Mid(EndOfWortString, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
'---------------------------------------------
' приставки на З
' без-(бес-), вз-(вс-), воз-(вос-), из-(ис-), низ-(нис-), раз-(рас-), роз-(рос-), через-(черес-)
Dim Prefix(1 To 9, 1 To 2)

Prefix(1, 1) = " без"
Prefix(1, 2) = " бес"
Prefix(2, 1) = " вз"
Prefix(2, 2) = " вс"
Prefix(3, 1) = " воз"
Prefix(3, 2) = " вос"
Prefix(4, 1) = " из"
Prefix(4, 2) = " ис"
Prefix(5, 1) = " низ"
Prefix(5, 2) = " нис"
Prefix(6, 1) = " раз"
Prefix(6, 2) = " рас"
Prefix(7, 1) = " роз"
Prefix(7, 2) = " рос"
Prefix(8, 1) = " через"
Prefix(8, 2) = " черес"
Prefix(9, 1) = " обез"
Prefix(9, 2) = " обес"

' перед глухой - з меняем на с
For i = 1 To 9
For j = 1 To Len(Deaf)
With Selection.Find
.Text = Prefix(i, 1) + Mid(Deaf, j, 1)
.Replacement.Text = Prefix(i, 2) + Mid(Deaf, j, 1)
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
' исправим косяк: образования от слова "низ" - низший, низкий и т.д.
With Selection.Find
.Text = " нисш"
.Replacement.Text = " низш"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = " ниск"
.Replacement.Text = " низк"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' а теперь исправим вновь созданный косяк - нисколько
With Selection.Find
.Text = "низколько"
.Replacement.Text = "нисколько"
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Sub