Разбивка на слоги

Признаюсь, всё, что касается применения программ к языку, словам, речи, отпугивает меня своей сложностью. Я считаю, что мне это пока что не под силу. Так было и в этот раз, когда на форуме я увидел тему о расстановке переносов. При обсуждении упомянули алгоритм Ляна-Кнута, суть которого состоит в определении набора правил переноса (шаблонов) и применения этих шаблонов к словам. Я нашёл упрощённый вариант этого алгоритма, который подкупает простотой и ясностью. Итак, каждое слово представляется как набор из трёх видов букв: гласных (g), согласных (s) и букв й, ь, ъ (x). Например, слово "семейство" будет выглядеть как "sgsgxsssg". Для такого упрощённого представления слова можно сформулировать несколько правил переноса (я реализовал 19):

1. "gssssg" → "gs-sssg", как в слове "чув-ствовать"
2. "gsssg" → "gss-sg", как в слове "шест-надцать"
3. "sgsssg" → "sgsssg", как в слове "откры-вать"
4. "gssxg" → "gs-sxg", как в слове "счас-тье"
5. "xgsg" → "xgsg", как в слове "кой-ка"
6. "xgg" → "xgg", как в слове "?"
7. "gssg" → "gs-sg", как в слове "оловян-ный"
8. "sgsg" → "sg-sg", как в слове "пе-рестройка"
9. "sggg" → "sggg", как в слове "?"
10. "sggs" → "sggs", как в слове "?"
11. "xgsg" → "xg-sg", как в слове "йо-гурт"
12. "xss" → "xss", как в слове "?"
13. "sgxsg" → "sgx-sg", как в слове "Незнай-ка"
14. "gsg" → "g-sg", как в слове "а-бажур"
15. "sgg" → "sg-g", как в слове "си-яние"
16. "sgsssgx" → "sgsssgx", как в слове "пере-стройка"
17. "sgsxsg" → "sgsx-sg", как в слове "малень-кий"
18. "sgssg" → "sg-ssg", как в слове "за-крывать"
19. "sgxg" → "sg-xg", как в слове "ра-йон"

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 
71 
72 
73 
74 
75 
76 
77 
78 
79 
80 
81 
82 
83 
84 
85 
86 
87 
88 
89 
90 
91 
92 
93 
94 
95 
96 
97 
98 
99 
100 
Public Type HyphenPair
    Pattern As String
    Position As Integer
End Type

Dim arHPairs() As HyphenPair
Private Const x As String = "йьъ"
Private Const g As String = "аеёиоуыэюяaeiouy"
Private Const s As String = "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz"

Public Function HyphenateWord(ByVal text As String, Optional Delimiter As String = "-", Optional DebugMode As Boolean = False) As String
    Dim i As Integer
    Dim sb As String
    Dim sText As String
    
    sText = StrConv(text, vbLowerCase)
    'Инициализация массива с шаблонами переноса
    Call Main
    
    'Формализация текста по шаблону xgs
    For i = 1 To Len(sText)
        If InStr(x, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "x"
        ElseIf InStr(g, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "g"
        ElseIf InStr(s, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "s"
        End If
    Next
    
    Dim hp As HyphenPair 'Текущий шаблон переноса
    Dim index As Integer 'положение шаблона в формализованном тексте
    Dim actualindex As Integer 'положение переноса в реальном тексте
    Dim FirstMatchFound As Boolean 'Флаг найденного совпадения в формализованном тексте
    Dim patternsBuff As String 'Отладочный буфер для записи сработавших шаблонов
    
    Do
        Dim temp As Integer
        Dim hptemp As HyphenPair
        FirstMatchFound = False
        'Поиск совпадения с шаблоном,
        'расположенного ближе всего к началу формализованного текста
        For i = 0 To UBound(arHPairs)
            hptemp = arHPairs(i)
            temp = InStr(sb, hptemp.Pattern)
            'Поиск первого совпадения
            If Not FirstMatchFound Then
                FirstMatchFound = InStr(sb, hptemp.Pattern)
                index = temp
                hp = hptemp
            End If
            If FirstMatchFound And temp <> 0 Then
                If temp < index Then
                    index = temp
                    hp = hptemp
                ElseIf temp = index Then
                    'при равных индексах предпочтение отдаётся более длинному шаблону
                    If Len(hptemp.Pattern) > Len(hp.Pattern) Then
                        index = temp
                        hp = hptemp
                    End If
                End If
            End If
        Next i
        If index <> 0 Then
            actualindex = index + hp.Position
            'Расстановка переносов в шаблоне
            sb = Mid(sb, 1, actualindex - 1) & Delimiter & Mid(sb, actualindex)
            'Расстановка переносов в тексте
            sText = Mid(sText, 1, actualindex - 1) & Delimiter & Mid(sText, actualindex)
            'Запись сработавшего паттерна
            patternsBuff = patternsBuff & " " & hp.Pattern
        End If
    Loop Until index = 0
    HyphenateWord = sText & IIf(DebugMode, vbCr & patternsBuff, "")
End Function

Sub Main()
    Dim hp As HyphenPair
    ReDim arHPairs(18)
    With arHPairs(0): .Pattern = "gssssg": .Position = 2: End With 'чув-ствовать
    With arHPairs(1): .Pattern = "gsssg": .Position = 2: End With 'откры-вать
    With arHPairs(2): .Pattern = "sgsssg": .Position = 4: End With 'шест-надцать
    With arHPairs(3): .Pattern = "gssxg": .Position = 2: End With 'счас-тье
    With arHPairs(4): .Pattern = "xgsg": .Position = 2: End With 'кой-ка
    With arHPairs(5): .Pattern = "xgg": .Position = 1: End With '?
    With arHPairs(6): .Pattern = "gssg": .Position = 2: End With 'оловян-ный
    With arHPairs(7): .Pattern = "sgsg": .Position = 2: End With 'пе-рестройка
    With arHPairs(8): .Pattern = "sggg": .Position = 2: End With '?
    With arHPairs(9): .Pattern = "sggs": .Position = 2: End With '?
    With arHPairs(10): .Pattern = "xgsg": .Position = 2: End With 'йо-гурт
    With arHPairs(11): .Pattern = "xss": .Position = 1: End With '?
    With arHPairs(12): .Pattern = "sgxsg": .Position = 3: End With 'май-ка
    With arHPairs(13): .Pattern = "gsg": .Position = 1: End With 'а-бажур
    With arHPairs(14): .Pattern = "sgg": .Position = 2: End With 'си-яние
    With arHPairs(15): .Pattern = "sgsssgx": .Position = 2: End With 'пере-стройка
    With arHPairs(16): .Pattern = "sgsxsg": .Position = 4: End With 'малень-кий
    With arHPairs(17): .Pattern = "sgssg": .Position = 2: End With 'за-крывать
    With arHPairs(18): .Pattern = "sgxg": .Position = 2: End With 'ра-йон
End Sub

Теоретически, должно работать для английского и русского, но тонкую подгонку я делал только для русского языка. Если найдёте слово (а оно есть и не одно), которое разбивается неправильно, — сообщите мне.

Кнопки управления окном на форме VBA

Стандартные средства не позволяют свернуть форму VBA или развернуть на весь экран. Но это можно сделать при помощи WinAPI

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const GWL_STYLE = (-16)

Public Sub ChangeWindow(f As UserForm)
  Dim hwnd As Long
  Dim retval As Long
  hwnd = FindWindow("ThunderDFrame", f.Caption)
  If hwnd <> 0 Then
    retval = SetWindowLong(hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
  End If
  If retval = 0 Then MsgBox "Fail"
End Sub

 1 
 2 
 3 
Private Sub UserForm_Initialize()
  Call ChangeWindow(Me)
End Sub

Результат для формы из старого документа:

Измерение производительности макросов (улучшение)

Предыдущий способ измерения производительности макросов был основан на использовании объекта Timer. Сегодня я хочу поделиться более совершенным инструментом для этой задачи, использующим функции WinAPI. Как и в прошлый раз замер производительности реализован с помощью класса, имеющего два метода Run и StopCounter, соответственно для запуска и остановки счётчика. При запуске можно задать имя процедуры производительность которой измеряется или любой другой поясняющий текст. Результат выводится в ImmediateWindow. Огромная благодарность пользователю karlex с форума bit.pirit за опубликованный код, на основе которого я сделал этот класс.

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 
71 
72 
73 
74 
75 
76 
77 
78 
79 
Option Explicit

'апи функция для получения значения счетчика
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long

'апи функция для получения значения частоты
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long

'апи функция для копирования области памяти
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'структура для хранения 64-разрядного числа
Private Type LARGE_INTEGER
    LowPart As Long
    HighPart As Long
End Type

Dim T As Long, _
    liFrequency As LARGE_INTEGER, _
    liStart As LARGE_INTEGER, _
    liStop As LARGE_INTEGER
    
Dim cuFrequency As Currency, cuStart As Currency, cuStop As Currency

'Имя процедуры, вызвавшей счётчик
Private m_ProcName As String

'Состояние счётчика производительности
Private m_CounterEnabled As Boolean

Public Property Get Enabled() As Boolean
    Enabled = m_CounterEnabled
End Property

'Запуск счётчика производительности
Public Sub Run(Optional ByVal ProcName As String = "")
    m_CounterEnabled = QueryPerformanceFrequency(liFrequency) <> 0
    If m_CounterEnabled Then
        'конвертировать 64-разрядное число в тип currency
        cuFrequency = LargeIntToCurrency(liFrequency)
        
        'получить количество "тиков"
        QueryPerformanceCounter liStart
    Else
        Debug.Print "Ваше аппаратное обеспечение не поддерживает счетчик производительности высокой точности!"
    End If
     m_ProcName = ProcName
End Sub

'Остановка счётчика производительности
Public Sub StopCounter()
    If m_CounterEnabled Then
        'получить количество "тиков"
        QueryPerformanceCounter liStop
        
        'конвертировать 64-разрядное число в тип currency
        cuStart = LargeIntToCurrency(liStart)
        cuStop = LargeIntToCurrency(liStop)
        
        'вычислить как много времени затрачено, и показать результат
        DebugPrint CStr(Round((cuStop - cuStart) / cuFrequency, 10))
    End If
End Sub

Private Sub DebugPrint(ByVal CounterValue As String)
    Dim s As String
    If Len(m_ProcName) > 0 Then s = "Имя процедуры: " & m_ProcName & vbCr
    s = s & "Длительность: " & CounterValue & " секунд."
    Debug.Print s
End Sub

'функция для конвертирования 64-разрядного числа в тип currency
Private Function LargeIntToCurrency(liInput As LARGE_INTEGER) As Currency
          'копировать 8 байт из 64-разрядного в currency
    CopyMemory LargeIntToCurrency, liInput, LenB(liInput)
    
    'adjust it - хз =)
    LargeIntToCurrency = LargeIntToCurrency * 10000
End Function

Скачать модуль класса Тест производительности перебора ячеек таблицы двумя разными способами: циклом For Each...Next и циклом Do Until...Loop

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
Sub test()
    Dim pc As New clPerformanceCounter
    Dim i As Integer
    Dim ocell As Cell
    pc.Run "Перебор ячеек циклом Do loop"
'    pc.Run "Перебор ячеек циклом For Each"
    Set ocell = ActiveDocument.Tables(1).Range.Cells(1)
    Do Until ocell Is Nothing
        Set ocell = ocell.Next
    Loop
'    For Each ocell In ActiveDocument.Tables(1).Range.Cells
'
'    Next
    pc.StopCounter
End Sub

Результат:

Имя процедуры: Перебор ячеек циклом For Each Длительность: 0,1546585742 секунд. Имя процедуры: Перебор ячеек циклом Do loop Длительность: 0,1063016398 секунд.

Копирование кода поля в буфер обмена

Часто сталкиваясь с необходимостью копирования кодов полей из Word, я решил упростить себе процесс и, посоветовавшись с сетевым разумом, сделал себе простенький макрос:

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
Sub CopyFieldCodes()
    If Selection.Range.Fields.Count = 0 Then Exit Sub
    Dim bFld As Boolean
    
    bFld = ActiveWindow.View.ShowFieldCodes
    
    ActiveWindow.View.ShowFieldCodes = True
    Dim s As String
    s = Replace(Replace(Selection.Text, Chr(19), "{"), Chr(21), "}")
    Debug.Print s
    ActiveWindow.View.ShowFieldCodes = bFld
    On Error Resume Next
    Dim dobj As New DataObject
    dobj.SetText s
    dobj.PutInClipboard
    Set dobj = Nothing
    If Err.Number <> 0 Then
        MsgBox "Невозможно скопировать код в буфер обмена", vbOK + vbCritical, "Код поля в буфер"
    Else
        MsgBox "Код поля скопирован в буфер обмена", vbOK + vbInformation, "Код поля в буфер"
    End If
End Sub

Чтобы код работал, нужно подключить Microsoft Forms 2.0 Object Library через меню Tools>References...

Объект Range и работа с ним.

Последнее время я часто сталкиваюсь с его использованием. На изученных мною ресурсах, посвященных VBA для Word, почему-то мало внимания уделяется такому важному представителю объектной модели. С его помощью можно, поистине, творить чудеса с документом.
Этот объект гораздо удобнее Selection, потому что позволяет не выделять нужную область на экране, а работать прямо с представлением документа в памяти. Это заметно ускоряет работу макросов, которые, по правде сказать, не отличаются быстродействием. При отладке программ бывает полезно воспользоваться методом Range.Select, чтобы убедиться, что вы работаете с нужным вам диапазоном.
Что же это за объект? Сразу хочу предупредить, что писать я буду, основываясь на своем понимании найденного и прочитанного в других источниках. В дословном переводе Range означает «Диапазон». Применительно к Word  — это означает диапазон свойств или методов, доступных для того или иного объекта. Например, как узнать текст второго абзаца в документе? Вот так:

    1 
ActiveDocument.Paragraphs(2).Range.Text

Стоит отметить, что это вернет весь текст в абзаце с символом конца абзаца (¶). Его можно удалить функцией Replace заменив символ vbCr на пустую строку.
Но главная фишка объекта Range совсем не в этом. А в том, что его можно передвигать и изменять в размерах практически произвольно (в пределах документа, естественно). У каждого объекта Range есть два свойства: Range.Start и Range.End. Начальный и конечный символ диапазона, считая от начала документа. Начало и конец диапазона можно задавать, указывая эти свойства напрямую, а можно такой конструкцией:

    1 
    2 
Dim oRng As Range
 Set oRng = ActiveDocument.Range(20, 50)

Изменить размер уже существующего диапазона можно с помощью метода SetRange, в котором указать номер символа, с которого диапазон начинается, и каким заканчивается. Этот метод используется тогда, когда нужно изменить уже существующий диапазон. Этот метод ничего не возвращает, а работает со своим родительским объектом

    1 
    2 
    3 
Dim oRng As Range
 Set oRng = ActiveDocument.Range
 oRng.SetRange 20, 50

С помощью Range можно получить такие объекты документа, для которых не предусмотрено коллекций, как, например, для абзацев (коллекция Paragraphs). Такими «бесхозными» объектами являются строки и страницы. Кто знает другие, пусть напишет.
Как получить страницу из документа со всем ее содержимым? Коллекции Pages не существует, что же делать? Вот здесь и понадобится Range и его метод GoTo

    1 
    2 
    3 
    4 
    5 
    6 
    7 
    8 
    9 
   10 
   11 
   12 
   13 
Sub TestGoTo()
  Dim oRng As Range
  'Даем в переменную oRng начало третьей страницы в документе.
  Set oRng = ThisDocument.Range.GoTo(wdGoToPage, wdGoToNext, , "3")
  MsgBox "Третья страница начинается с " & oRng.Start & " символа.", 64, "Метод GoTo"
  'Расширяем диапазон oRng на всю третью страницу
  Set oRng = ThisDocument.Range(oRng.Start, oRng.GoToNext(wdGoToPage).Start)
  MsgBox "На третьей странице находится " & oRng.Paragraphs.Count & " абзацев.", 64, "Метод GoTo"
  'Берем 10 строку с третьей страницы
  Set oRng = oRng.GoTo(wdGoToLine, wdGoToNext, 10)
  Set oRng = ThisDocument.Range(oRng.Start, oRng.GoToNext(wdGoToLine).Start)
  MsgBox "В десятой строке третьей страницы содержится " & oRng.Characters.Count & " символов.", 64, "Метод GoTo"
End Sub

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