Склонение фамилии, имени и отчества

Листинг 3.85. Склонение ФИО

Public Sub PossessiveCase()

' Склоняем ФИО в родительный падеж

Dim strName1 As String, strName2 As String, strName3 As String

strName1 = dhGetName(ActiveCell, 1) ' Выделяем имя

strName2 = dhGetName(ActiveCell, 2) ' Выделяем фамилию

strName3 = dhGetName(ActiveCell, 3) ' Выделяем отчество

' Если в ячейке менее трех слов - закрытие процедуры

If strName1 = " " Or strName2 = " " Or strName3 = " " Then Exit Sub

' Склоняем

Cells(ActiveCell.Row, ActiveCell.Column) = dhPossessive(_

strName1, strName2, strName3)

End Sub

Public Sub DativeCase()

' Объявление переменных

Dim strName1 As String, strName2 As String, strName3 As String

strName1 = dhGetName(ActiveCell, 1)

strName2 = dhGetName(ActiveCell, 2)

strName3 = dhGetName(ActiveCell, 3)

' Если в ячейке менее трех слов - закрытие процедуры

If Len(strName1) = 0 Or Len(strName2) = 0 Or Len(strName3) = 0 _

Then Exit Sub

Cells(ActiveCell.Row, ActiveCell.Column) = dhDative(_

strName1, strName2, strName3)

End Sub

Function dhPossessive(strName1 As String, strName2 As String, _

strName3 As String) As String

Dim fMan As Boolean

' Определяем, мужские ФИО или женские

fMan = (Right(strName3, 1) = " ч")

' Склонение фамилии в родительный падеж

If Len(strName1) > 0 Then

If fMan Then

' Склонение мужской фамилии

Select Case Right(strName1, 1)

Case " о", " и", " я", " а"

dhPossessive = strName1

Case " й"

dhPossessive = Mid(strName1, 1, Len(strName1) - 2) + " ого"

Case Else

dhPossessive = strName1 + " а"

End Select

Else

' Склонение женской фамилии

Select Case Right(strName1, 1)

Case " о", " и", " б", " в", " г", " д", " ж", " з", " к", " л", _

" м", " н", " п", " р", " с", " т", " ф", " х", " ц", " ч", _

" ш", " щ", " ь"

dhPossessive = strName1

Case " я"

dhPossessive = Mid(strName1, 1, Len(strName1) - 2) & " ой"

Case Else

dhPossessive = Mid(strName1, 1, Len(strName1) - 1) & " ой"

End Select

End If

dhPossessive = dhPossessive & " "

End If

' Склонение имени в родительный падеж

If Len(strName2) > 0 Then

If fMan Then

' Склонение мужского имени

Select Case Right(strName2, 1)

Case " й", " ь"

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & " я"

Case Else

dhPossessive = dhPossessive & strName2 & " а"

End Select

Else

' Склонение женского имени

Select Case Right(strName2, 1)

Case " а"

Select Case Mid(strName2, Len(strName2) - 1, 1)

Case " и", " г"

dhPossessive = dhPossessive & Mid(_

strName2, 1, Len(strName2) - 1) & " и"

Case Else

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & " ы"

End Select

Case " я"

If Mid(strName2, Len(strName2) - 1, 1) = " и" Then

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & " и"

Else

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & " и"

End If

Case " ь"

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & " и"

Case Else

dhPossessive = dhPossessive & strName2

End Select

End If

dhPossessive = dhPossessive & " "

End If

' Склонение отчества в родительный падеж

If Len(strName3) > 0 Then

If fMan Then

dhPossessive = dhPossessive & strName3 & " а"

Else

dhPossessive = dhPossessive & Mid(strName3, 1, _

Len(strName3) - 1) & " ы"

End If

End If

End Function

Function dhDative(strName1 As String, strName2 As String, _

strName3 As String) As String

Dim fMan As Boolean

' Определяем, мужские ФИО или женские

fMan = (Right(strName3, 1) = " ч")

' Склонение фамилии в дательный падеж

If Len(strName1) > 0 Then

If fMan Then

' Склонение мужской фамилии

Select Case Right(strName1, 1)

Case " о", " и", " я", " а"

dhDative = strName1

Case " й"

dhDative = Mid(strName1, 1, Len(strName1) - 2) + " ому"

Case Else

dhDative = strName1 + " у"

End Select

Else

' Склонение женской фамилии

Select Case Right(strName1, 1)

Case " о", " и", " б", " в", " г", " д", " ж", " з", " к", " л", _

" м", " н", " п", " р", " с", " т", " ф", " х", " ц", " ч", " ш", _

" щ", " ь"

dhDative = strName1

Case " я"

dhDative = Mid(strName1, 1, Len(strName1) - 2) & " ой"

Case Else

dhDative = Mid(strName1, 1, Len(strName1) - 1) & " ой"

End Select

End If

dhDative = dhDative & " "

End If

' Склонение имени в дательный падеж

If Len(strName2) > 0 Then

If fMan Then

' Склонение мужского имени

Select Case Right(strName2, 1)

Case " й", " ь"

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & " ю"

Case Else

dhDative = dhDative & strName2 & " у"

End Select

Else

' Склонение женского имени

Select Case Right(strName2, 1)

Case " а", " я"

If Mid(strName2, Len(strName2) - 1, 1) = " и" Then

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & " и"

Else

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & " е"

End If

Case " ь"

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & " и"

Case Else

dhDative = dhDative & strName2

End Select

End If

dhDative = dhDative & " "

End If

' Склонение отчества в дательный падеж

If Len(strName3) > 0 Then

If fMan Then

dhDative = dhDative & strName3 & " у"

Else

dhDative = dhDative & Mid(strName3, 1, Len(strName3) - 1) & " е"

End If

End If

End Function

Function dhGetName(strString As String, intNum As Integer)

' Функция возвращает слово с номером intNum во входной строке _

strString

Dim strTemp As String

Dim intWord As Integer

Dim intSpace As Integer

' Удаление пробелов по краям строки

strTemp = Trim(strString)

' Просмотр строки (до слова с нужным номером)

For intWord = 1 To intNum - 1

' Поиск следующего пробела

intSpace = InStr(strTemp, " ")

If intSpace = 0 Then

' Строка закончилась

intSpace = Len(strTemp)

End If

' Строка strTemp теперь начинается со слова с номером intWord

strTemp = Trim(Right(strTemp, Len(strTemp) - intSpace))

Next intWord

' Выделение нужного слова (по пробелу после него)

intSpace = InStr(strTemp, " ")

If intSpace = 0 Then

intSpace = Len(strTemp)

End If

dhGetName = Trim(Left(strTemp, intSpace))

End Function