Алексей Гладкий - Excel. Трюки и эффекты

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

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 The

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

Чтобы ФИО отобразились в родительном падеже, следует установить курсор в ячейку с этими ФИО и запустить макрос PossessiveCase; в дательном падеже – макрос DativeCase (после написания кода эти макросы будут доступны в окне выбора макросов).

Внимание!

Для реализации трюка необходимо соблюдать условие – ячейка должна содержать не менее трех слов. В противном случае операция выполнена не будет.

Следует учитывать, что в ячейке сначала должна следовать фамилия, за ней – имя, и затем – отчество.

Данный макрос не всегда способен корректно обрабатывать сложные имена и фамилии.

С помощью небольшого макроса можно вывести на экран информацию об используемом принтере. Код макроса записывается в стандартном модуле редактора VBA и выглядит следующим образом (листинг 3.83).

' Объявление API-функции

Declare Function GetProfileStringA Lib «kernel32» _

(ByVal lpAppName As String, ByVal lpKeyName As String, _

ByVal lpDefault As String, ByVal lpReturnedString As _

String, ByVal nSize As Long) As Long

Sub Принтер()

Dim strFullInfo As String * 255 ' Буфер для API-функции

Dim strInfo As String ' Строка с полной информацией

Dim strPrinter As String ' Название принтера

Dim strDriver As String ' Драйвер принтера

Dim strPort As String ' Порт принтера

Dim strMessage As String

Dim intPrinterEndPos As Integer

Dim intDriverEndPos As Integer

' Заполнение буфера пробелами

strFullInfo = Space(255)

' Получение полной информации о принтере

Call GetProfileStringA(«Windows», «Device», "", strFullInfo,

254)

' Удаление лишних символов из конца возвращенной строки

' Строка strInfo имеет формат <���имя_принтера>,<���драйвер>,<-

порт>:

strInfo = Trim(strFullInfo)

' Поиск запятых в строке (окончаний названий принтера и драйвера)