Склонение Фио И Должности Во Всех Падежах!

cybergeene · 13.02.2012

Код:

%REM
Library Padeg
переведено с кода 1С
Created Feb 12, 2012 by Евгений Меднов/Евгений Меднов
// (c) Jurer Production Begin ( Start )
// В случае, если программа окажется для Вас полезной, и Вы представляете только свои интересы, а не интересы фирмы,
// автор будет весьма признателен, если Вы перечислите ему, то есть мне, некую сумму на Ваше усмотрение
// Счет для я-деньги: 4100131343416 - будьте ж несдержаней в своих инициативах
// 
// http://superjur.narod.ru
// 
// Удаление этих строк незнаконно!
// Гарантия 91 года и 1 месяц!!!
// Послегарантийное обслуживание - бесплатно!!!
// Круглосуточная поддержка - все 48 часов в бою!
// Ссылка на источник обязательна!
// Эти программы защищены законом об авторских правах. Запрещается перепродажа данной программы.
// ПРОВЕРЕНО! ВИРУСОВ НЕТ!!! АНТИВИРУСОВ ТОЖЕ!!!
// Смотри Милячуша в творительном !!
// скупой слепой тупой - пропой!!
// !№№!
// !56! укратил
// !55! ПадежЫ - для оглы и кызы
// !54! 
// !53! Очередное сокращение кода
// !51! Прегромадное спасибо Олегу Дубровскому за оказанную моральную, информационную и материальную поддержку сего проекта.
//	 Сергею Толкачёву за напоминание о том, что в русском языке всегда есть место исключениям!
// !50! П:Ответственный за электрохозяйство Ф:Ацута Груша 
// !48! исправлена ошибка при склонении фамилий (спасибо, Mario).
// !47! исправлена ошибка при склонении профессий ( спасибо, Павел Ковалев).
// !46! оптимизация + четвертый параметр задает, что вернуть - фамилия, имя или отчество или всё сразу в нужном падеже
// !42! Осел + Соловей + Воробей + Немец + Кормилец + Силиец
// !41! отчества оканчивающиеся на "ы" считаются женскими ?
// Функция для склонения одного слова!!!
// z1 - само слово
// z2 - номер падежа
// z3 - пол
// z4 - 1-склонять как фамилию, 2-имя, 3-отчество
%END REM
Option Public


Sub Terminate

End Sub
%REM
Function Max
Description: Comments for Function
%END REM
Function Max(x As Variant, y As Variant) As Variant
If x>y Then
Max = x
Else
Max = y
End If
End Function

Function Падеж(z1,z2,z3,z4,z5) As String
%rem
//_____________________________________________________________________________
// z1 - фамилия имя отчество например Железняков Юрий Юрьевич
// z2 - Падеж ( по умолчанию = 2 - родительный)
// 2 - родительный ( нет кого?	) Железнякова Юрия Юрьевича	 
// 3 - дательный	( кому?		) Железнякову Юрию Юрьевичу 
// 4 - винительный ( вижу кого?  ) Железнякова Юрия Юрьевича 
// 5 - творительный ( кем?		 ) Железняковым Юрием Юрьевичем	
// 6 - предложный  ( о ком?	  ) Железнякове Юрии Юрьевиче 
// Если задать Z2 меньше 0, то на выходе получим от -1=Железняков Ю. Ю. до -6=Железнякове Ю. Ю.
// z3 - параметр Пол может не указываться, но при наличии фамилий с 
// инициалами точное определение пола невозможно, поэтому предлагается задавать пол этим
// параметром 1 - мужской 2 - женский 
// ДЛЯ СКЛОНЕНИЯ ПРОФЕССИЙ ИСПОЛЬЗУЙТЕ ФУНКЦИЮ ПАДЕЖП И БУДЕТ ВАМ СЧАСТЬЕ!
// ПадежП(должность,род(число),0) - форма для вызова
// ---------------------------------------------------------------------------------------
// Бибик Галушка Цой Николайчик Наталия Петровна Герценберг Кривошей Капица-Метелица
// Если Падеж(Фио ,1 ,3),	  то на выходе получим Фамилия Имя Отчество и т.д.
// Если Падеж(Фио ,1 ,3,"1" ), то				  Фамилия 
// Если Падеж(Фио ,1 ,3,"2" ), то				  Имя 
// Если Падеж(Фио ,1 ,3,"3" ), то				  Отчество 
// Если Падеж(Фио, 1 ,3,"12" ), то				  Фамилия Имя 
// Если Падеж(Фио, 1 ,3,"23" ), то				  Имя Отчество 
// Если Падеж(Фио,-1 ,3,"231" ),то				  И. О. Фамилия 
// Если Падеж(Фио,-1 ,3,"23" ), то				  И. О. 
// 10-11-2003 3-20
%End rem
'z1,z2=2,z3=3,z4="123",z5=1 - значения, которые можно задать по умолчанию
z6=LCase(Right(RTrim(z1),4))
z7=Right(z6,1)
'Падеж = IIf(z5<4,Падеж(Trim(Replace(Mid(z1,InStr(z1+" "," ")+1),".",". ")),z2,z3,Replace(z4,z5,ПадежС(IIf((z5=3)And(z7="ы"),z1,Left(z1,InStr(z1+" "," ")-1)),z2,Mid("ча"+z7,IIf(z3=3,IIf(z6="оглы",1,IIf(z6="кызы",1,3)),z3),1),z5)+" "),z5+1),z4)
If z5<4 Then
Падеж = Падеж(Trim(Replace(Mid(z1,InStr(z1+" "," ")+1),".",". ")),z2,z3,Replace(z4,CStr(z5),ПадежС(IIf((z5=3)And(z7="ы"),z1,Left(z1,InStr(z1+" "," ")-1)),z2,Mid("ча"+z7,IIf(z3=3,IIf(z6="оглы",1,IIf(z6="кызы",1,3)),z3),1),z5)+" "),z5+1)
Else
Падеж = z4
End If
End Function


%REM
Function IIf
Description: Comments for Function
%END REM
Function IIf(bool As Boolean, x As Variant, y As Variant) As Variant
If bool Then
IIf = x
Else
IIf = y
End If
End Function

'Function ПадежП(z1,z2,z3) As String
Function ПадежП(ByVal z1,ByVal z2,z3) As String
'ByVal z1,ByVal z2,z3=0
z1=Trim(z1):z4=InStr(z1+" "," ")+1:z5=Left(z1,z4-2):z6=Right(z5,2)
z7=IIf((InStr("ая ий ый",z6)>0)And(InStr("ющий нный",Mid(z1,z4-5,4))=0)And(z3=0),"1","*")
'ПадежП = LCase(IIf((z6="ая")Or(Right(z6,1)="а"),ПадежС(z5,z2,z7,1)+" "+ПадежС(Mid(z1,z4),z2,"*",0),ПадежС(z5,z2,"ч",1)+IIf((z6="ий")And(InStr(z1," ")=0),""," "+IIf(z7="1",ПадежП(Mid(z1,z4),z2,CInt(z7)),Mid(z1,z4)))))
If (z6="ая")Or(Right(z6,1)="а") Then
var = ПадежС(z5,z2,z7,1)+" "+ПадежС(Mid(z1,z4),z2,"*",0)
Else
If (z6="ий")And(InStr(z1," ")=0) Then
var1 = ""
Else
If z7= "1" Then
var1 = ПадежП(Mid(z1,z4),z2,CInt(z7))
Else
var1 = Mid(z1,z4)
End If
var1= " "+var1
End If
var = ПадежС(z5,z2,"ч",1)+var1
End If
ПадежП = LCase(var)
End Function

Function ПадежС(z1,ByVal z2,ByVal z3,z4) As String
'z1,Знач z2=2,Знач z3="*",z4=0

z5=InStr(z1,"-")
'z6 = IIf(z5 = 0, "", "-" + ПадежС(Mid(z1, z5 + 1, Len(z1) - z5 + 1), z2, z3, z4))
If z5 = 0 Then
z6 = ""
Else
z6 = "-" + ПадежС(Mid(z1, z5 + 1, Len(z1) - z5 + 1), z2, z3, z4)
End If
'z1 = LCase(IIf(z5 = 0, z1, Left(z1, z5 - 1)))
If z5 = 0 Then
z1 = LCase(z1)
Else
z1 = Left(z1, z5 - 1)
End If
z7=Right(z1,3):z8=Right(z7,2):z9=Right(z8,1)
z5=Len(z1)
za=InStr("ая ия ел ок яц ий па да ца ша ба та га ка",z8) 
zb=InStr("аеёийоуэюяжнгхкчшщ",Left(z7,1)) 
zc=Max(z2,-z2) 
'zd=IIf(za=4,5,InStr("айяь",z9)) 
If za=4 Then
zd = 5 
Else
zd = InStr("айяь",z9)
End If
zd=IIf((zc=1)Or(z9=".")Or((z4=2)And(InStr("оиеу"+IIf(z3="ч","","бвгджзклмнпрстфхцчшщъ"),z9)>0))Or((z4=1)And(InStr("мия мяэ лия кия жая лея",z7)>0)),9,IIf((zd=4)And(z3="ч"),2,IIf(z4=1,IIf(InStr("оеиую",z9)+InStr("их ых аа еа ёа иа оа уа ыа эа юа яа",z8)>0,9,IIf(z3<>"ч",IIf(za=1,7,IIf(z9="а",IIf(za>18,1,6),9)),IIf(((InStr("ой ый",z8)>0)And(z5>4)And(Right(z1,4)<>"опой"))Or((zb>10)And(za=16)),8,zd))),zd))) 
ze=InStr("лец вей бей дец пец мец нец рец вец аец иец ыец бер",z7) 
zf=IIf((zd=8)And(zc<>5),IIf((zb>15)Or(InStr("жий ний",z7)>0),"е","о"),IIf(z1="лев","ьв",IIf((InStr("аеёийоуэюя",Mid(z1,z5-3 ,1))=0)And((zb>11)Or(zb=0))And(ze<>45),"",IIf(za=7,"л",IIf(za=10,"к",IIf(za=13,"йц",IIf(ze=0,"",IIf(ze<12,"ь"+IIf(ze=1,"ц",""),IIf(ze<37,"ц",IIf(ze<49,"йц","р")))))))))) 
'// zf=IIf((zd=9)Or((z4=3)и(z3="ы")),z1,Left(z1,z5-IIf((zd>6)Or(zf<>""),2,IIf(zd>0,1,0)))+zf+RTrim(Mid("а у а "+Mid("оыые",InStr("внч",z9)+1,1)+"ме "+IIf(InStr("гжкхш",Left(z8,1))>0,"и","ы")+" е у ойе я ю я ем"+IIf(za=16,"и","е")+" и е ю ейе и и ь ьюи и и ю ейи ойойу ойойойойуюойойгомуго"+IIf((zf="е")Or(za=16)Or((zb>12)и(zb<16)),"и","ы")+"мм",10*zd+2*zc-3,2))) 
zf=IIf((zd=9)Or((z4=3)And(Right(z1,1)="ы")),z1,Left(z1,z5-IIf((zd>6)Or(zf<>""),2,IIf(zd>0,1,0)))+zf+RTrim(Mid("а у а "+Mid("оыые",InStr("внч",z9)+1,1)+"ме "+IIf(InStr("гжкхш",Left(z8,1))>0,"и","ы")+" е у ойе я ю я ем"+IIf(za=16,"и","е")+" и е ю ейе и и ь ьюи и и ю ейи ойойу ойойойойуюойойгомуго"+IIf((zf="е")Or(za=16)Or((zb>12)And(zb<16)),"и","ы")+"мм",10*zd+2*zc-3,2))) 
ПадежС = IIf(""=z1,"",IIf(z4>0,UCase(Left(zf,1))+IIf((z2<0)And(z4>1),".",Mid(zf,2)),zf)+z6) 
End Function

cybergeene · 24.02.2012

функции возвращают сколонения в нижнем регистре (кроме ФИО).
функции возвращают лишний пробел справа, так что используйте RTrim

Для того чтобы вернуть регистр букв используйте функцию:

Код:

Function sameStrCase(strOrig As String, ByVal strCh As String) As String
Dim strChElem As String
Dim lenOrig As Long
Dim lenCh As Long
Dim cnt As Long
Dim cntMax As Long
Dim i As Long
Dim strOrigArr As Variant
Dim strChArr As Variant
Dim letterOrig As String, letterCh As String
Dim strFinal As String

If strCh = "" Then
sameStrCase = ""
Exit Function
End If

strCh = LCase(strCh)
strOrigArr = Split(strOrig, " ")
strChArr = Split(strCh, " ")
cntMax = UBound(strChArr) 'чтобы не зайти за пределы массива
cnt=0
ForAll j In strOrigArr
strChElem = strChArr(cnt)
lenOrig = Len(j)
lenCh = Len(strChElem)
If lenOrig>lenCh Then
lenOrig = lenCh 'чтобы не нарваться на выход за пределы строки
End If

For i = 1 To lenOrig
letterOrig = Mid( j,i,1)
letterCh = Mid( strChElem,i,1)
If letterOrig = UCase(letterCh) Then
Mid(strChArr(cnt),i,1) = letterOrig
End If
Next
cnt = cnt +1
If cnt > cntMax Then Exit ForAll 'во избежании ошибки переполнения
End ForAll

ForAll j In strChArr
strFinal = strFinal + j +" "
End ForAll

sameStrCase = RTrim(strFinal)

End Function

samai · 23.11.2012

Спасибо очень интересный код. Но не будет ли лучше заставить пользователей самим вводить все необходимые падежи ?

Eugen · 06.03.2022

Добрый вечер.

Кто-нибудь еще использует этот код? Если фамилия из трех букв, то сыпется с ошибкой "Illegal function call" где-то в методе ПадежП. Никто не сталкивался?
Дебагер вылетает почему-то постоянно, не могу выяснить причину.

Все сервисы Codeby

Поиск

Поиск

Склонение Фио И Должности Во Всех Падежах!

cybergeene

cybergeene

samai

Eugen