Склонение должностей и славянских ФИО в родительном и дательном падежах (Валерий Крук)

Автор: Крук Валерий Николаевич
По материалам: http://am.rusimport.ru/msaccess/topic.aspx?ID=585

Код из примера:

Option Compare Database
Option Explicit

Dim TX(17) As String

'*******************************************************************************************
' © Крук Валерий Николаевич, 2006
'   KrukVN
'*******************************************************************************************
'
'-------------------- Склонение должностей и славянских ФИО --------------------------------
'---------------------- в родительном и дательном падежах ----------------------------------
'
'Код начал создаваться примерно с 2003 года.
'Сначала мне казалось сущим пустяком решение подобной проблемы, но потом, написав часть,
'я плюнул на все это дело, т.к. понял, что не все так просто.
'Этот код как дорогая ручка, которую сам себе не купишь и ждешь пока кто-нибудь
'догадается подарить тебе ее на день рождения. Т.е. писать самому ну очень не хотелось.
'Все ждал, что в инете появится что-нибудь подходящее, но... все что появлялось
'меня не устраивало. А время шло... код стал ветвится и обрастать новыми строками
'В итоге из маленького и робкого он превратился в плутоватого монстра
'
'Возможно в коде что-то не учел, хотя перелопатил достаточно много различных вариантов
'должностей и фамилий, а может где-то просто ошибся, поэтому прошу: не ругайте сильно
'Если требуется просклонировать что-то, что кодом не предусмотрено, то можно использовать
'функцию склонения слов-исключений 'Iskluchenie'
'А может быть вообще имеет смысл создать что-то вроде вспомогательного словаря для
'склонения слов-исключений ('Sklon.txt' например)
'
'Для пользователей Access 97
'Этот пример может не работать из-за использования в нем функции 'Split'
'Как аналог этой функции могу предложить свой вариант:
'Function MySplit(ByVal StrValues As String, ByVal Separator As String) As Variant
'Dim i As Integer, j As Integer, k As Integer, Arr() As String
'    StrValues = Separator + StrValues + Separator
'    ReDim Arr(0)
'    i = 1: j = 1
'    Do
'        i = InStr(j, StrValues, Separator)
'        j = InStr(i + 1, StrValues, Separator)
'        If j = 0 Then Exit Do
'        k = k + 1
'        ReDim Preserve Arr(k - 1)
'        Arr(k - 1) = Mid(StrValues, i + 1, j - i - 1)
'    Loop
'    MySplit = Arr
'End Function
'
'-------------------------------------------------------------------------------------------
'
'Склонение должностей
'Считаем, что должность мужского рода и склоняем ее как фамилию.
Function SklonDoljn(ByVal MyStr As String, ByVal Padej As String) As String
On Error GoTo Err_SklonDoljn
Dim Doljn() As String, i As Integer, j As Byte, tmp As String
    MyStr = Trim(MyStr)
    If InStr(1, MyStr, "-") > 0 Then
        'Обработка человеческого фактора (спасает в 99% случаев)
        MyStr = Replace(MyStr, " - ", "-")
        MyStr = Replace(MyStr, "- ", "-")
        MyStr = Replace(MyStr, " -", "-")
    End If
        Doljn = Split(MyStr, " ") 'Режем на отдельные слова
        'Обработка человеческого фактора (удаляем лишние пробелы)
        If InStr(1, MyStr, "  ") > 0 Then
            MyStr = ""
            For i = 0 To UBound(Doljn)
                If Doljn(i) <> "" Then MyStr = MyStr & " " & Doljn(i)
            Next i
            MyStr = Mid(MyStr, 2)
            Doljn = Split(MyStr, " ") 'И опять режем на отдельные слова
        End If
        'Если предыдущее слово заканчивается на 'й', то склонять нужно и следующее
        'Например: ГлавныЙ инженер/механик/электрик/бухгалтер; СтаршиЙ преподаватель;
        'МладшиЙ научныЙ сотрудник; ГенеральныЙ директор/секретарь/подрядчик
        If GlDoljn(Doljn(0)) = True Then
            j = 1
            For i = 1 To UBound(Doljn)
                If GlDoljn(Doljn(i - 1)) = True Then
                    If j = 1 Then
                        SklonDoljn = SklonDoljn & " " & SklonFIO(Doljn(i - 1), "м", Padej) & " " & SklonFIO(Doljn(i), "м", Padej)
                      Else
                        SklonDoljn = SklonDoljn & " " & SklonFIO(Doljn(i), "м", Padej)
                    End If
                    j = 0
                  Else
                    SklonDoljn = SklonDoljn & " " & Doljn(i)
                    j = 1
                End If
            Next i
        End If
        If SklonDoljn = "" Then
            'Склоняем только первое слово
            SklonDoljn = SklonFIO(Doljn(0), "м", Padej)
            'Склоняем все последующие слова
            For i = 1 To UBound(Doljn)
                tmp = Iskluchenie(Doljn(i), Padej) 'Проверка на слова-исключения
                If tmp = "" Then
                    SklonDoljn = SklonDoljn & " " & Doljn(i)
                  Else
                    SklonDoljn = SklonDoljn & " " & tmp
                End If
            Next i
        End If
    SklonDoljn = Trim(SklonDoljn)
Exit Function
Err_SklonDoljn:
    SklonDoljn = MyStr
End Function

'Склонение ФИО и должностей
Function SklonFIO(ByVal Slovo As String, ByVal Rod As String, ByVal Padej As String) As String
Dim i As Integer, FIO() As String, Tire() As String, j As Integer, tmp As String
    FIO = Split(Slovo, " ")
    For i = 0 To UBound(FIO)
        'Если в слове есть тире, то склоняем то что до тире и то что после
        '(Инженер-технолог, слесарь-электрик, штукатур-маляр,
        'Сухово-Кобылин, Козьма-Прудков, Козо-Полянский)
        If InStr(1, FIO(i), "-") > 0 Then
            Tire = Split(FIO(i), "-")
            For j = 0 To UBound(Tire)
                Select Case Padej
                    Case "Rod" 'Родительный (кого, чего)
                        tmp = Iskluchenie(Tire(j), Padej) 'Проверка на слова-исключения
                        If tmp = "" Then
                            SklonFIO = SklonFIO & "-" & SklonenieRod(Tire(j), Rod)
                          Else
                            SklonFIO = SklonFIO & "-" & tmp
                        End If
                    Case "Dat" 'Дательный (кому, чему)
                        tmp = Iskluchenie(Tire(j), Padej) 'Проверка на слова-исключения
                        If tmp = "" Then
                            SklonFIO = SklonFIO & "-" & SklonenieDat(Tire(j), Rod)
                          Else
                            SklonFIO = SklonFIO & "-" & tmp
                        End If
                End Select
            Next j
            SklonFIO = Mid(SklonFIO, 2)
          Else
            Select Case Padej
                Case "Rod" 'Родительный (кого, чего)
                    tmp = Iskluchenie(FIO(i), Padej) 'Проверка на слова-исключения
                    If tmp = "" Then
                        SklonFIO = SklonFIO & SklonenieRod(FIO(i), Rod) & " "
                      Else
                        SklonFIO = SklonFIO & tmp & " "
                    End If
                Case "Dat" 'Дательный (кому, чему)
                    tmp = Iskluchenie(FIO(i), Padej) 'Проверка на слова-исключения
                    If tmp = "" Then
                        SklonFIO = SklonFIO & SklonenieDat(FIO(i), Rod) & " "
                      Else
                        SklonFIO = SklonFIO & tmp & " "
                    End If
            End Select
        End If
    Next i
    SklonFIO = RTrim(SklonFIO)
End Function

'================================================================================================
'Склонение ФИО (и некоторых слов) в родительном падеже
'================================================================================================
Private Function SklonenieRod(ByVal Slovo As String, ByVal Rod As String) As String
Dim str1 As String, str2 As String, str3 As String
    Slovo = RTrim$(Slovo)
    If Len(Slovo) = 0 Then Exit Function
    str1 = Right$(Slovo, 1) 'последняя буква
    If Len(Slovo) > 1 Then str2 = Mid$(Slovo, Len(Slovo) - 1, 1)  'вторая буква справа
    If Len(Slovo) > 2 Then str3 = Mid$(Slovo, Len(Slovo) - 2, 1)  'третья буква справа
If Rod = "м" Then 'Если род МУЖСКОЙ =============================================================
Select Case str1
    Case "а"
        Select Case str2
            Case "б", "д", "в", "з", "л", "м", "н", "п", "р", "с", "т", "ф", "ц"
                str1 = "ы"
            Case Else
                str1 = "и"
        End Select
    Case "б"
        str1 = "ба"
    Case "в"
        str1 = "ва"
    Case "г"
        str1 = "га"
    Case "д"
        str1 = "да"
    Case "ж"
        str1 = "жа"
    Case "з"
        str1 = "за"
    Case "й"
        Select Case str2
            Case "е"
                Select Case Slovo
                    Case "Соловей", "Воробей"
                        str2 = "ь"
                End Select
                str1 = "я"
            Case "и"
                Select Case str3
                    Case "г", "к", "х"
                        str1 = "ого"
                        str2 = vbNullString
                    Case "ж", "з", "н", "ч", "ш", "щ"
                        str1 = "его"
                        str2 = vbNullString
                    Case Else
                        str1 = "я"
                End Select
            Case "о", "ы"
                str1 = "ого"
                str2 = vbNullString
            Case Else
                str1 = "я"
        End Select
    Case "к"
        str1 = "ка"
        If str2 = "о" Then str2 = vbNullString
    Case "л"
        Select Case str2
            Case "е"
                Select Case Slovo
                    Case "Козел", "Орел", "Пепел", "Бусел", "Котел", "Дятел", "Павел"
                        str2 = vbNullString
                End Select
            Case Else
        End Select
        str1 = "ла"
    Case "м"
        str1 = "ма"
    Case "н"
        Select Case Slovo
            Case "Бубен"
                str2 = vbNullString
        End Select
        str1 = "на"
    Case "п"
        str1 = "па"
    Case "р"
        str1 = "ра"
    Case "с"
        str1 = "са"
    Case "т"
        str1 = "та"
    Case "ф"
        str1 = "фа"
    Case "х"
        Select Case str2
            Case "и", "ы"
                If Len(Slovo) < 4 Then str1 = "ха"
            Case Else
                str1 = "ха"
        End Select
    Case "ц"
        Select Case str2
            Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
               Select Case str3
                  Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
                    str2 = "й"
               End Select
              'If str2 = "е" Then
                 If Len(Slovo) > 3 Then
                   Select Case Mid$(Slovo, Len(Slovo) - 3, 1) 'четвертая буква справа
                     Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
                         If str3 = "л" Then
                            str2 = "ь"
                          Else: str2 = vbNullString
                         End If
                   End Select
                 End If
              'End If
               str1 = "ца"
            Case Else
               str1 = "ца"
        End Select
    Case "ч"
        str1 = "ча"
    Case "ш"
        str1 = "ша"
    Case "щ"
        str1 = "ща"
    Case "я"
        Select Case str2
            Case "а", "е", "и", "о", "у", "ы", "э", "ю", "я"
                str1 = "я"
            Case Else
                str1 = "и"
        End Select
    Case "у"
        str1 = "и"

    Case "ь"
        str1 = "я"
End Select
Else 'Если род ЖЕНСКИЙ ==========================================================================
Select Case str1
    Case "а"
        Select Case str2
            Case "б", "д", "з", "л", "м", "п", "р", "с", "т", "ф", "ц"
                str1 = "ы"
            Case "в"
                Select Case Slovo
                    Case "Ева"
                        str1 = "ы"
                    Case Else
                        Select Case str3
                            Case "а", "е", "ё", "и", "о"
                                str1 = "ой"
                            Case Else
                                str1 = "ы"
                        End Select
                End Select
            Case "н"
                Select Case Slovo
                    Case "Илона", "Юнона", "Нона", "Ирина", "Галина", "Светлана", _
                    "Валентина", "Екатерина", "Татьяна", "Марина", "Кристина", "Полина", _
                    "Дина", "Нина", "Антонина", "Карина", "Елена", "Алена", "Сторона"
                        str1 = "ы"
                    Case Else
                        Select Case str3
                            Case "а", "е", "ё", "и", "о"
                                str1 = "ой"
                            Case Else
                                str1 = "ы"
                        End Select
                End Select
            Case "г", "ж", "к", "х", "ч", "ш", "щ"
                str1 = "и"
        End Select
    Case "я"
        Select Case str2
            Case "а"
                Select Case str3
                    Case "ж", "ч", "ш", "щ"
                        str1 = "ей"
                        str2 = vbNullString
                    Case Else
                        str1 = "ой"
                        str2 = vbNullString
                End Select
            Case "е", "и", "о", "у", "э", "ы", "ю", "ь", "л", "с", "д"
                str1 = "и"
            Case "я"
                str1 = "ей"
                str2 = vbNullString
        End Select
End Select
End If
    If Len(Slovo) <= 2 Then
       SklonenieRod = Slovo
    Else
       SklonenieRod = Mid(Slovo, 1, Len(Slovo) - 2) & str2 & str1
    End If
End Function

'================================================================================================
'Склонение ФИО (и некоторых слов) в дательном падеже
'================================================================================================
Private Function SklonenieDat(ByVal Slovo As String, ByVal Rod As String) As String
Dim str1 As String, str2 As String, str3 As String
    Slovo = RTrim$(Slovo)
    If Len(Slovo) = 0 Then Exit Function
    str1 = Right$(Slovo, 1) 'последняя буква
    If Len(Slovo) > 1 Then str2 = Mid$(Slovo, Len(Slovo) - 1, 1)  'вторая буква справа
    If Len(Slovo) > 2 Then str3 = Mid$(Slovo, Len(Slovo) - 2, 1)  'третья буква справа
If Rod = "м" Then 'Если род МУЖСКОЙ =============================================================
Select Case str1
    Case "а"
        Select Case str2
            Case "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", "р", "с", "т", "ф", "ц", "ч", "ш", "щ"
                str1 = "е"
            Case Else
                str1 = "ю"
        End Select
    Case "б"
        str1 = "бу"
    Case "в"
        str1 = "ву"
    Case "г"
        str1 = "гу"
    Case "д"
        str1 = "ду"
    Case "ж"
        str1 = "жу"
    Case "з"
        str1 = "за"
    Case "й"
        Select Case str2
            Case "е"
                Select Case Slovo
                    Case "Соловей", "Воробей"
                        str2 = "ь"
                End Select
                str1 = "ю"
            Case "и"
                Select Case str3
                    Case "г", "к", "х"
                        str1 = "ому"
                        str2 = vbNullString
                    Case "ж", "з", "н", "ч", "ш", "щ"
                        str1 = "ему"
                        str2 = vbNullString
                    Case Else
                        str1 = "ю"
                End Select
            Case "о", "ы"
                str1 = "ому"
                str2 = vbNullString
            Case Else
                str1 = "ю"
        End Select
    Case "к"
        str1 = "ку"
        If str2 = "о" Then str2 = vbNullString
    Case "л"
        Select Case str2
            Case "е"
                Select Case Slovo
                    Case "Козел", "Орел", "Пепел", "Бусел", "Котел", "Дятел", "Павел"
                        str2 = vbNullString
                End Select
            Case Else
        End Select
        str1 = "лу"
    Case "м"
        str1 = "му"
    Case "н"
        Select Case Slovo
            Case "Бубен"
                str2 = vbNullString
        End Select
        str1 = "ну"
    Case "п"
        str1 = "пу"
    Case "р"
        str1 = "ру"
    Case "с"
        str1 = "су"
    Case "т"
        str1 = "ту"
    Case "ф"
        str1 = "фу"
    Case "х"
        Select Case str2
            Case "и", "ы"
                If Len(Slovo) < 4 Then str1 = "ху"
            Case Else
                str1 = "ху"
        End Select
    Case "ц"
        Select Case str2
            Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
               Select Case str3
                  Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
                    str2 = "й"
               End Select
              'If str2 = "е" Then
                 If Len(Slovo) > 3 Then
                   Select Case Mid$(Slovo, Len(Slovo) - 3, 1) 'четвертая буква справа
                     Case "а", "е", "ё", "и", "о", "у", "э", "ю", "я"
                         If str3 = "л" Then
                            str2 = "ь"
                          Else: str2 = vbNullString
                         End If
                   End Select
                 End If
              'End If
               str1 = "цу"
            Case Else
               str1 = "цу"
        End Select
    Case "ч"
        str1 = "чу"
    Case "ш"
        str1 = "шу"
    Case "щ"
        str1 = "щу"
    Case "я"
        Select Case str2
            Case "а", "е", "и", "о", "у", "ы", "э", "ю", "я"
                str1 = "ю"
            Case Else
                str1 = "е"
        End Select
    Case "у"
        str1 = "у"
    Case "ь"
        str1 = "ю"
End Select
Else 'Если род ЖЕНСКИЙ ==========================================================================
Select Case str1
    Case "а"
        Select Case str2
            Case "б", "д", "з", "л", "м", "п", "р", "с", "т", "ф", "ц"
                str1 = "е"
            Case "в"
                Select Case Slovo
                    Case "Ева"
                        str1 = "е"
                    Case Else
                        Select Case str3
                            Case "а", "е", "ё", "и", "о"
                                str1 = "ой"
                            Case Else
                                str1 = "е"
                        End Select
                End Select
            Case "н"
                Select Case Slovo
                    Case "Илона", "Юнона", "Нона", "Ирина", "Галина", "Светлана", _
                    "Валентина", "Екатерина", "Татьяна", "Марина", "Кристина", "Полина", _
                    "Дина", "Нина", "Антонина", "Карина", "Елена", "Алена", "Сторона"
                        str1 = "е"
                    Case Else
                        Select Case str3
                            Case "а", "е", "ё", "и", "о"
                                str1 = "ой"
                            Case Else
                                str1 = "е"
                        End Select
                End Select
            Case "г", "ж", "к", "х", "ч", "ш", "щ"
                str1 = "е"
        End Select
    Case "я"
        Select Case str2
            Case "а"
                Select Case str3
                    Case "ж", "ч", "ш", "щ"
                        str1 = "ей"
                        str2 = vbNullString
                    Case Else
                        str1 = "ой"
                        str2 = vbNullString
                End Select
            Case "е", "и", "о", "у", "э", "ы", "ю", "ь", "л", "с", "д"
                str1 = "е"
            Case "я"
                str1 = "ей"
                str2 = vbNullString
        End Select
End Select
End If
    If Len(Slovo) <= 2 Then
       SklonenieDat = Slovo
    Else
       SklonenieDat = Mid(Slovo, 1, Len(Slovo) - 2) & str2 & str1
    End If
End Function

'Проверка сокращения должности
Private Function GlDoljn(ByVal Doljn As String) As Boolean
    Select Case Doljn
        Case "Гл.", "Ст.", "Мл.", "Ген.", "Эл.", "Деж.", "Вед."
            GlDoljn = True
            Exit Function
    End Select
    If Right(Doljn, 1) = "й" Then
        If Doljn <> "Заведующий" Then
            GlDoljn = True
        End If
    End If
End Function

'Обработка слов-исключений
'Внимание: прежде чем внести новое слово-исключение обратите внимание на то как
'   оно склоняется кодом
'Например должности: Медсестра; Санитарка; Маникюрщица; Поэтесса; Актриса;
'   Певица; Манекенщица; Путана; Гейша и некоторые другие склоняются вполне
'   нормально по закону склонения мужских фамилий
Private Function Iskluchenie(ByVal Slovo As String, ByVal Padej As String) As String
    Select Case Padej
        Case "Rod"
            Select Case Slovo
                Case "Старшая": Iskluchenie = Left(Slovo, 1) & "таршей"
                Case "Швея": Iskluchenie = Left(Slovo, 1) & "веи"
                Case "Горничная": Iskluchenie = Left(Slovo, 1) & "орничной"
                Case "Кухонная": Iskluchenie = Left(Slovo, 1) & "ухонной"
                Case "Рабочая": Iskluchenie = Left(Slovo, 1) & "абочей"
                Case "Дежурная": Iskluchenie = Left(Slovo, 1) & "ежурной"
                Case "Дочь": Iskluchenie = Left(Slovo, 1) & "очери"
                Case "Любовь": Iskluchenie = Left(Slovo, 1) & "юбови"
                Case "Майя": Iskluchenie = Left(Slovo, 1) & "айи"
            End Select
        Case "Dat"
            Select Case Slovo
                Case "Старшая": Iskluchenie = Left(Slovo, 1) & "таршей"
                Case "Швея": Iskluchenie = Left(Slovo, 1) & "вее"
                Case "Горничная": Iskluchenie = Left(Slovo, 1) & "орничной"
                Case "Кухонная": Iskluchenie = Left(Slovo, 1) & "ухонной"
                Case "Рабочая": Iskluchenie = Left(Slovo, 1) & "абочей"
                Case "Дежурная": Iskluchenie = Left(Slovo, 1) & "ежурной"
                Case "Дочь": Iskluchenie = Left(Slovo, 1) & "очери"
                Case "Любовь": Iskluchenie = Left(Slovo, 1) & "юбови"
                Case "Майя": Iskluchenie = Left(Slovo, 1) & "айе"
            End Select
    End Select
End Function

MSA-2003 ( 37 kB) Пример