Биохимия спиртового брожения: Основу технологии получения пива составляет спиртовое брожение, - при котором сахар превращается...
Общие условия выбора системы дренажа: Система дренажа выбирается в зависимости от характера защищаемого...
Топ:
Установка замедленного коксования: Чем выше температура и ниже давление, тем место разрыва углеродной цепи всё больше смещается к её концу и значительно возрастает...
Оценка эффективности инструментов коммуникационной политики: Внешние коммуникации - обмен информацией между организацией и её внешней средой...
Устройство и оснащение процедурного кабинета: Решающая роль в обеспечении правильного лечения пациентов отводится процедурной медсестре...
Интересное:
Уполаживание и террасирование склонов: Если глубина оврага более 5 м необходимо устройство берм. Варианты использования оврагов для градостроительных целей...
Отражение на счетах бухгалтерского учета процесса приобретения: Процесс заготовления представляет систему экономических событий, включающих приобретение организацией у поставщиков сырья...
Финансовый рынок и его значение в управлении денежными потоками на современном этапе: любому предприятию для расширения производства и увеличения прибыли нужны...
Дисциплины:
2021-10-05 | 45 |
5.00
из
|
Заказать работу |
Листинг 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
Автоматическое растормаживание колес: Тормозные устройства колес предназначены для уменьшения длины пробега и улучшения маневрирования ВС при...
Состав сооружений: решетки и песколовки: Решетки – это первое устройство в схеме очистных сооружений. Они представляют...
Индивидуальные и групповые автопоилки: для животных. Схемы и конструкции...
Таксономические единицы (категории) растений: Каждая система классификации состоит из определённых соподчиненных друг другу...
© cyberpedia.su 2017-2024 - Не является автором материалов. Исключительное право сохранено за автором текста.
Если вы не хотите, чтобы данный материал был у нас на сайте, перейдите по ссылке: Нарушение авторских прав. Мы поможем в написании вашей работы!