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

Тема в разделе "Oбщий функционал", создана пользователем cybergeene, 13 фев 2012.

  1. cybergeene

    cybergeene Member

    Регистрация:
    7 мар 2008
    Сообщения:
    21
    Симпатии:
    0
    Код (LotusScript):
    %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
     
  2. cybergeene

    cybergeene Member

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

    Для того чтобы вернуть регистр букв используйте функцию:
    Код (LotusScript):
    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
     
  3. samai

    samai Гость

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

Поделиться этой страницей