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

Признаюсь, всё, что касается применения программ к языку, словам, речи, отпугивает меня своей сложностью. Я считаю, что мне это пока что не под силу. Так было и в этот раз, когда на форуме я увидел тему о расстановке переносов. При обсуждении упомянули алгоритм Ляна-Кнута, суть которого состоит в определении набора правил переноса (шаблонов) и применения этих шаблонов к словам. Я нашёл упрощённый вариант этого алгоритма, который подкупает простотой и ясностью. Итак, каждое слово представляется как набор из трёх видов букв: гласных (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 секунд.

Как получить системную иконку для определённого файла?

Чтобы получить и отобразить на форме иконку, используемую системой для определённого типа файлов, необходимо: иметь контейнер для отображения этой иконки и знать расширение файла :). В качестве контейнера это может быть системная иконка формы либо любой элемент управления, принимающий изображение. Итак, для работы понадобится форма и модуль:

 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 
Option Explicit
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
                        (lpPictDesc As PictDesc, _
                        riid As Guid, _
                        ByVal fPictureOwnsHandle As Long, _
                        ipic As IPicture) As Long
Public Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" _
                        (ByVal hInst As Long, _
                        ByVal lpIconPath As String, _
                        lpiIcon As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                        (ByVal lpClassName As String, _
                        ByVal lpWindowName As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                        (ByVal hwnd As Long, _
                        ByVal wMsg As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Public Const WM_SETICON = &H80

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
    
Public Function IconToPicture(ByVal hIcon As Long) As IPicture
    
    If hIcon = 0 Then Exit Function
        
    Dim oNewPic As IPicture
    Dim tPicConv As PictDesc
    Dim IGuid As Guid
    
    With tPicConv
       .cbSizeofStruct = Len(tPicConv)
       .picType = 3 'vbPicTypeIcon
       .hImage = hIcon
    End With
    
    ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With IGuid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    
    Set IconToPicture = oNewPic
    DestroyIcon hIcon
End Function

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

Dim hwnd As Long
Dim hIcon As Long

Private Sub CommandButton1_Click()
    If hwnd <> 0 Then
        hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
        Image1.Picture = IconToPicture(hIcon)
    End If
End Sub

Private Sub CommandButton2_Click()
    If hwnd <> 0 Then
        hIcon = ExtractAssociatedIcon(hwnd, Application.ActiveDocument.FullName, 0)
        SendMessage hwnd, WM_SETICON, 0, hIcon
    End If
End Sub

Private Sub UserForm_Initialize()
    hwnd = FindWindow("ThunderDFrame", Me.Caption)
    Me.Caption = "&H" & Hex(hwnd)
End Sub

Документ с примером

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

Часто сталкиваясь с необходимостью копирования кодов полей из 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...