Function
AccusativeCase(sSurname$,
Optional
sName$,
Optional
sPatronymic$)
As
String
Application.Volatile
True
sSurname$ = Replace(sSurname$,
" - "
,
"-"
): sSurname$ = Replace(Replace(sSurname$,
" -"
,
"-"
),
"- "
,
"-"
)
On
Error
Resume
Next
If
sName$ =
""
And
sPatronymic$ =
""
Then
arr = Split(Application.Trim(sSurname$))
sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2),
"."
,
""
)
End
If
Dim
bMaleSex
As
Boolean
:
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) &
"уя"
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
AccusativeCase = Join(arrSurname,
"-"
) &
" "
End
If
If
Len(sName) > 0
Then
NameException$ = GetAccusativeException(sName)
If
Len(NameException$)
Then
AccusativeCase = AccusativeCase & NameException$
Else
If
bMaleSex
Then
Select
Case
Right(sName, 1)
Case
"й"
,
"ь"
: AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) &
"я"
Case
"а"
: AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) &
"у"
Case
"я"
: AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) &
"ю"
Case
"о"
,
"и"
: AccusativeCase = AccusativeCase & sName
Case
Else
: AccusativeCase = AccusativeCase & sName &
"а"
End
Select
Else
Select
Case
Right(sName, 1)
Case
"а"
: AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) &
"у"
Case
"я"
: AccusativeCase = AccusativeCase & Mid(sName, 1, Len(sName) - 1) &
"ю"
Case
Else
: AccusativeCase = AccusativeCase & sName
End
Select
End
If
End
If
AccusativeCase = AccusativeCase &
" "
End
If
If
Len(sPatronymic) > 0
Then
If
Right(sPatronymic, 4) =
"оглы"
Or
Right(sPatronymic, 4) =
"кызы"
Then
AccusativeCase = AccusativeCase & sPatronymic
Else
If
bMaleSex
Then
AccusativeCase = AccusativeCase & sPatronymic &
"а"
Else
AccusativeCase = AccusativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) &
"у"
End
If
End
If
End
If
AccusativeCase = Replace(AccusativeCase,
"-"
,
"- "
)
AccusativeCase = StrConv(AccusativeCase, vbUnicode + vbProperCase)
AccusativeCase = Trim(Replace(AccusativeCase,
"- "
,
"-"
))
End
Function
Function
GetAccusativeException(
ByVal
txt$)
As
String
Select
Case
txt$
Case
"Павел"
: GetAccusativeException =
"Павла"
Case
"Лев"
: GetAccusativeException =
"Льва"
Case
"Пётр"
: GetAccusativeException =
"Петра"
End
Select
End
Function