Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 28.08.2021, 10:19   #1
Otradnoe_4D
 
Регистрация: 06.03.2018
Сообщений: 8
По умолчанию Склонение имени

Доброе время суток. Нашёл на просторах интернета такой код
Код:
Function GenitiveCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует родительный падеж из ФИО
    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество
    ' © 2013 EducatedFool

    sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")

    On Error Resume Next
    If sName$ = "" And sPatronymic$ = "" Then
        arr = Split(TrimAll(sSurname$))
        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")
    End If

    ' пол теперь определяется иначе:   что заканчивается на "вна" или "кызы" - то женщины, остальные - мужчины.
    Dim bMaleSex As Boolean:    ' bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 4) = "оглы")
    bMaleSex = Not (Right(sPatronymic, 2) = "на" Or Right(sPatronymic, 4) = "кызы")

    If Len(sSurname) > 0 Then    '   Фамилия
        arrSurname = Split(sSurname, "-")
        For i = LBound(arrSurname) To UBound(arrSurname)    ' перебираем все части фамилий, содержащих дефис
            sRes = "": sSurnamePart = arrSurname(i)

            If bMaleSex Then    ' мужские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "и", "ы", "у", "э", "е", "ю": sRes = sSurnamePart
                    Case "й": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                    Case "ь": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ы"
                        If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart
                    Case Else: sRes = sSurnamePart & "а"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ец":  sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ца"
                        If LCase(sSurnamePart) Like "*[уеыаоэяиюё]ец" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ца"
                        If LCase(sSurnamePart) Like "*[!уеыаоэяиюё][!уеыаоэяиюё]ец" Then sRes = sSurnamePart & "а"
                    Case "зе", "их", "ых": sRes = sSurnamePart
                    Case "ий", "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                        If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                        If Right(sSurnamePart, 3) = "чий" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "его"
                    Case "уй": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "уя"
                End Select

            Else    ' женские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ой"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ю"
                    Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "у"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "хи"
                    Case "ла": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "лы"
                    Case "ая": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ой"
                End Select

            End If

            ' не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю,
            ' а также на -а с предшествующей гласной
            If LCase(sSurnamePart) Like "*[уеыаоэяиюё]а" Then sRes = sSurnamePart

            arrSurname(i) = sRes
        Next
        GenitiveCase = Join(arrSurname, "-") & " "    ' соединяем части склоняемой фамилии обратно в одну строку
    End If

    If Len(sName) > 0 Then    '   Имя
        NameException$ = GetGenitiveException(sName)
        If Len(NameException$) Then    ' для имен-исключений
            GenitiveCase = GenitiveCase & NameException$
        Else    ' имя не найдено в списке исключений
            If bMaleSex Then
                Select Case Right(sName, 1)
                    Case "й", "ь": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "я"
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case "о": GenitiveCase = GenitiveCase & sName
                    Case Else: GenitiveCase = GenitiveCase & sName & "а"
                End Select
            Else
                Select Case Right(sName, 1)
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case Else: GenitiveCase = GenitiveCase & sName
                End Select
                
            End If
        End If
        
        GenitiveCase = GenitiveCase & " "
    End If

    If Len(sPatronymic) > 0 Then    '   Отчество
        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then
            GenitiveCase = GenitiveCase & sPatronymic
        Else
            If bMaleSex Then
                GenitiveCase = GenitiveCase & sPatronymic & "а"
            Else
                GenitiveCase = GenitiveCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "ы"
            End If
        End If
    End If
    GenitiveCase = Replace(GenitiveCase, "-", "- ")
    GenitiveCase = StrConv(GenitiveCase, vbProperCase)
    GenitiveCase = Replace(GenitiveCase, "- ", "-")
End Function

Function GetGenitiveException(ByVal txt$) As String    ' склонение имён-исключений
    Select Case txt$
        Case "Павел": GetGenitiveException = "Павла"
        Case "Лев": GetGenitiveException = "Льва"
        Case "Пётр": GetGenitiveException = "Петра"
        Case "Любовь": GetGenitiveException = "Любови"
        

            ' без изменения (не склоняются) - перечисляем через запятую
        Case "Али", "Бали": GetGenitiveException = txt$
    End Select
End Function

Function TrimAll(s As String) As String

'Удаляет пробелы в начале и конце строки,
'заменяет кратные пробелы внутри строки на одиночные пробелы
'аналогично функции Application.Trim в Excel

Dim i&, j&
TrimAll = Trim$(s)
j = Len(TrimAll)
Do
    i = j
    TrimAll = Replace$(TrimAll, "  ", " ")
    j = Len(TrimAll)
Loop Until i = j
End Function
После чего попытался его модифицировать и добавил где склонение имени следующее
Код:
Select Case Right(sName, 1)
Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
Case Else: GenitiveCase = GenitiveCase & sName
End Select

Select Case Right(sName, 2)
Case "ка": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"

End Select
В результате выдаёт: Вероникывероники
Что делаю не так? Как исправить?
Otradnoe_4D вне форума Ответить с цитированием
Старый 28.08.2021, 10:53   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

потому что "вероника" 2 разы обрабатывается.
Попробуйте поиграться с таким фрагментом (не проверял)
Код:
Select Case Right(GenitiveCase , 2)
Case "ка": GenitiveCase =  Mid(GenitiveCase , 1, Len(GenitiveCase ) - 1) & "и"
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
склонение месяца в DTPicker1 DMITRIY_78 Microsoft Office Excel 2 19.08.2019 11:14
Склонение ФИО irina181 Microsoft Office Word 1 15.11.2017 16:07
Склонение ФИО Lokos Общие вопросы Delphi 4 11.09.2014 08:05
Склонение существительных за 100р. KOMPNET Помощь студентам 6 22.12.2011 08:26
Склонение существительных KOMPNET Фриланс 1 21.12.2011 20:56