Регистрация: 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
В результате выдаёт: Вероникывероники
Что делаю не так? Как исправить?
|