Код:
%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