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

Листинг 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

 

ГЛАВА. ДАТА И ВРЕМЯ

Вывод даты и времени_1

Sub Test()

 Dim MyDate As Date

 MyDate = DateValue("6/1/72") + TimeValue("10:10:12")

 MsgBox Str(Minute(MyDate))

 MsgBox Str(Year(MyDate))

End Sub

Вывод даты и времени_2

 

Sub TimeAndDate()

Dim strDate As String, strTime As String

Dim strGreeting As String

Dim strUserName As String

Dim intSpacePos As Integer

 

strDate = Format(Date, "Long Date")

strTime = Format(Time, "Medium Time")

' Приветствие - в зависимости от времени суток

If Time < TimeValue("12:00") Then

strGreeting = "Доброе утро, "

ElseIf Time < TimeValue("17:00") Then

strGreeting = "Добрый день, "

Else

strGreeting = "Добрый вечер, "

End If

' В приветствие добавляется имя текущего пользователя

strUserName = Application.UserName

intSpacePos = InStr(1, strUserName, " ", 1)

' Управление ситуацией, когда в имени нет пробела

If intSpacePos = 0 Then intSpacePos = Len(strUserName)

strGreeting = strGreeting & Left(strUserName, intSpacePos)

 

' Вывод на экран информационного сообщения о дате и времени

MsgBox strDate & vbCrLf & strTime, vbOKOnly, strGreeting

End Sub

 

Получение системной даты

Извлечение даты и часов

Month(переменная типа Date)

Day(переменная типа Date)

Year(переменная типа Date)

Hour(переменная типа Date)

Minute(переменная типа Date)

Second(переменная типа Date)

WeekDay(переменная типа Date)

WeekDay это день недели, если Вам это нужно, то вы можете написать что-то типа этого.

Sub Test()

 Dim MyDate As Date

 MyDate = DateValue("9/1/72")

 If (WeekDay(MyDate) = vbSunday) Then MsgBox ("Sunday")

End Sub

vbSunday это константа, есть еще vbMonday, ну дальше понятно.

Функция ДатаПолная

Function ДатаПолная(Ячейка)

' Получение данных в заданной ячейке в формате _

"dd mmmm yyyy"

Дата = Format(Ячейка, "dd mmmm yyyy")

If IsDate(Ячейка) = True Or IsDate(Дата) = True Then

' Возврат строки с полной датой

ДатаПолная = StrConv(Дата, vbProperCase)

Else

' Данные в ячейке не являются датой

ДатаПолная = "<>"

End If

End Function