Option Compare Database
Option Explicit
'Авторство:
'     (c) Jurer Production [SuperJur.Narod.Ru]'
'Перевод на RSL
'     (с) yu [rsl_my@mail.ru]
'С RSL assa 2004

' _____________________________________________________________________________
'  z1 - фамилия имя отчество например Железняков Юрий Юрьевич
'  z2 - Падеж ( по  умолчанию = 2 - родительный)
'  2 - родительный  ( нет кого?    ) Железнякова Юрия Юрьевича
'  3 - дательный    ( кому?        ) Железнякову Юрию Юрьевичу
'  4 - винительный  ( вижу кого?   ) Железнякова Юрия Юрьевича
'  5 - творительный ( кем?         ) Железняковым Юрием Юрьевичем
'  6 - предложный   ( о ком?       ) Железнякове Юрии Юрьевиче
'  Если задать Z2 меньше 0, то на выходе получим от -1=Железняков Ю. Ю. до -6=Железнякове Ю.Ю.

'  z3 - параметр Пол может не указываться, но при наличии фамилий с
'  инициалами точное определение пола невозможно, поэтому предлагается задавать пол этим
'  параметром  1 - мужской 2 - женский
'  ДЛЯ СКЛОНЕНИЯ ПРОФЕССИЙ ИСПОЛЬЗУЙТЕ ФУНКЦИЮ ПАДЕЖП И БУДЕТ ВАМ СЧАСТЬЕ!
'  ---------------------------------------------------------------------------------------
'  Бибик Галушка Цой Николайчик Наталия Петровна Герценберг Кривошей Капица-Метелица
'  Если ПадежФИО(Фио ,1 ,3),       то на выходе получим Фамилия Имя Отчество и т.д.
'  Если ПадежФИО(Фио ,1 ,3,"1" ),  то                   Фамилия
'  Если ПадежФИО(Фио ,1 ,3,"2" ),  то                   Имя
'  Если ПадежФИО(Фио ,1 ,3,"3" ),  то                   Отчество
'  Если ПадежФИО(Фио, 1 ,3,"12" ), то                   Фамилия Имя
'  Если ПадежФИО(Фио, 1 ,3,"23" ), то                   Имя Отчество
'  Если ПадежФИО(Фио,-1 ,3,"231" ),то                   И. О. Фамилия
'  Если ПадежФИО(Фио,-1 ,3,"23" ), то                   И. О.
'*/
Function ПадежФИО(ByVal z1, Optional ByVal z2, Optional ByVal z3, Optional ByVal z4, Optional ByVal z5)
    If IsNull(z1) Then
        ПадежФИО = Null
        Exit Function
    End If
 
  
Dim vsp, vsp1, vsp2

On Error Resume Next
    z1 = Trim(z1 & "")
    If err = 63933 Then
        ПадежФИО = Null
        Exit Function
    End If
On Error GoTo 0
    If (TypeName(z2) = "Error") Then
        z2 = 2
    End If
    If (TypeName(z3) = "Error") Then
        z3 = 3
    End If
    If (TypeName(z4) = "Error") Then
        z4 = "123"
    End If
    If (TypeName(z5) = "Error") Then
        z5 = 1
    End If
    If (z5 < 4) Then
        vsp = Trim(СтрЗаменить(Mid(z1, InStr(z1 + " ", " ") + 1), ".", ". "))
        vsp1 = MidNew(z1, 1, (InStr(z1 + " ", " ") - 1))
        'vsp2 = MidNew("ча" + LCase(MidNew(z1, (Len(z1)))), (z3), 1)
        vsp2 = MidNew("ча" + (MidNew(z1, (Len(z1)))), (z3), 1)
        ПадежФИО = ПадежФИО(vsp, z2, z3, СтрЗаменить(z4, z5, ПадежСл(vsp1, z2, vsp2, z5) + " "), z5 + 1)
    Else
        ПадежФИО = z4
    End If
End Function

'  z1 - наименование профессии, как одно слово, так и несколько слов. Например
'       звукорежиссер, инженер - программист 1 категории, заместитель технического директора
'  z2 - номер падежа (1 - именительный, 2 - родительный, 3 -  дательный, 4 - винительный,
'  5 - творительный, 6 - предложный)
'  z3 - служебная переменная
'  Пример вызова ПадежП("агент по снабжению", 2 ) для родительного падежа.
'  Пример вызова ПадежП("ведущий инженер-программист 2 категории", 3 ) для дательного падежа.

Function ПадежП(ByVal z1, Optional ByVal z2, Optional ByVal z3)
    If IsNull(z1) Then
        ПадежП = Null
        Exit Function
    End If
    If (TypeName(z3) = "Error") Then
        z3 = 0
    End If
    z1 = Trim(z1)
Dim z4, z5, z6, z7, ret As String
    z4 = InStr(z1 + " ", " ") + 1
    z5 = MidNew(z1, 1, (z4 - 2))
    z6 = MidNew(z5, (Len(z5) - 1))
    If ((InStr("ая ий ый", z6) > 0) And (InStr("ющий нный", MidNew(z1, nZ(z4) - 5, 4)) = 0) And (z3 = 0)) Then
        z7 = "1"
    Else
        z7 = "*"
    End If
    If ((z6 = "ая") Or (MidNew(z6, (Len(z6))) = "а")) Then
        '    ПадежП = LCase(ПадежСл(z5, z2, z7, 1) + " " + ПадежСл(MidNew(z1, (z4)), z2))
        ПадежП = (ПадежСл(z5, z2, z7, 1) + " " + ПадежСл(MidNew(z1, (z4)), z2))
    Else
        ret = ПадежСл(z5, z2, "ч", 1)
        If ((z6 = "ий") And (InStr(z1, " ") = 0)) Then
            ret = ret + ""
        Else
            ret = ret + " "
            If (z7 = "1") Then
                ret = ret + ПадежП(MidNew(z1, (z4)), z2, Int(z7))
            Else
                ret = ret + MidNew(z1, nZ(z4))
            End If
        End If
      'ПадежП = LCase(ret)
      ПадежП = ret
    End If
End Function


Function ПадежСл(ByVal z1, Optional ByVal z2, Optional ByVal z3, Optional ByVal z4)
Dim z5, z6, z7, z8, z9, z10, z11, z12, z13, z14, tmp, vsp
    If (TypeName(z2) = "Error") Then    'V_UNDEF 'Unknown'Empty
        z2 = 2
    End If
    If (TypeName(z3) = "Error") Then
        z3 = "*"
    End If
    If (TypeName(z4) = "Error") Then
        z4 = 0
    End If
    z5 = InStr(z1, "-")
    If (z5 = 0) Then
        z6 = ""
    Else
        z6 = "-" + ПадежСл(MidNew(z1, (z5 + 1), Len(z1) - z5 + 1), z2, z3, z4)
        z1 = Mid(z1, 1, z5 - 1)
    End If
    If ((z2 < 0) And (z4 > 1) And (z1 <> "")) Then
        'z1 = LCase(Mid(z1, 1, 1)) + "."
        z1 = (Mid(z1, 1, 1)) + "."
        z14 = z1
    Else
        'z1 = LCase(z1)
        z7 = MidNew(z1, (Len(z1) - 2))
        z8 = MidNew(z7, (Len(z7) - 1))
        z9 = MidNew(z8, (Len(z8)))
        If (((z4 = 2) And ((z3 = "а") Or (z3 = "ы")) And (InStr("бвгджзклмнопрстфхцчшщъиеу", z9) > 0)) _
          Or ((z4 = 2) And (z3 = "ч") And (InStr("оиеу", z9) > 0)) Or ((z4 = 1) _
          And (InStr("мия мяэ лия кия жая лея", z7) > 0))) Then
          z2 = 1
        Else
          z2 = Abs(z2)
        End If
        z5 = Len(z1)
        z10 = InStr("ая ия ел ок яц ий па да ца ша ба та га ка", z8)
        If (z4 = 1) Then
            If (InStr("оеиую", z9) + InStr("их ых аа еа ёа иа оа уа ыа эа юа яа", z8) > 0) Then
                z11 = -1
            Else
                If ((z3 = "а") Or (z3 = "ы")) Then
                    If (z10 = 1) Then
                        z11 = 8
                    Else
                        If (z9 = "а") Then
                            If (z10 > 18) Then
                                z11 = 3
                            Else
                                z11 = 9
                            End If
                        Else
                            z11 = -1
                        End If
                    End If
                Else
                    If (((InStr("ой ый", z8) > 0) And (z5 > 4)) Or (InStr("гий жий кий ний чий хий ший щий ", z7) > 0)) Then
                        z11 = 10
                    Else
                        z11 = 0
                    End If
                End If
            End If
        Else
            z11 = 0
        End If
        If (z11 = 0) Then
            If (z10 = 4) Then
                z11 = 7
            Else
                z11 = InStr(".чайяь", z9)
            End If
        End If
        z12 = InStr("лец вей дец пец мец нец рец вец аец иец ыец бер бей", z7)
    
        If ((z11 = 10) And (z2 <> 5)) Then
            If (InStr("чшщ", Mid(z7, 1, 1)) + InStr("жий ний", z7) > 0) Then
                z14 = "е"
            Else
                z14 = "о"
            End If
        Else
            If (z1 = "лев") Then
                z14 = "ьв"
            Else
                If ((InStr("аеёийоуэюя", MidNew(z1, (z5 - 3), 1)) + InStr("аеёийоуэюя", Mid(z7, 1, 1)) = 0) And _
                    (z12 <> 41)) Then
                    z14 = ""
                Else
                    If (z10 = 7) Then
                        z14 = "л"
                    Else
                        If (z10 = 13) Then
                            z14 = "йц"
                        Else
                            If (z12 = 0) Then
                                z14 = ""
                            Else
                                If ((z12 < 9) Or (z12 = 49)) Then
                                    If (z12 = 1) Then
                                        z14 = "ьц"
                                    Else
                                        z14 = "ь"
                                    End If
                                Else
                                    If (z12 < 33) Then
                                        z14 = "ц"
                                    Else
                                        If (z12 < 45) Then
                                            z14 = "йц"
                                        Else
                                            z14 = "р"
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
      
        If ((z2 = 1) Or (z11 < 0) Or ((z4 = 3) And (z3 = "ы") Or ("" = z1))) Then
            z14 = z1
        Else
            If ((z11 = 8) Or (z14 <> "") Or (z11 = 10)) Then
                tmp = z5 - 2
            Else
                If (z11 > 2) Then
                    tmp = z5 - 1
                Else
                    tmp = z5
                End If
            End If
      
            z14 = Mid(z1, 1, tmp) + z14
            tmp = "а у а " + Mid("оыыыоео", InStr(" внтчц", z9) + 1, 1) + "ме           а у а еме "
            If (InStr("гжкхш", Mid(z8, 1, 1)) > 0) Then
                tmp = tmp + "и"
            Else
                tmp = tmp + "ы"
            End If
                tmp = tmp + " е у ойе я ю я ем"
            If (z10 = 16) Then
                tmp = tmp + "и"
            Else
                tmp = tmp + "е"
            End If
            tmp = tmp + " и е ю ейе и и ь ьюи и и ю ейи ойойуюойойойойу ойойгомуго"
            If ((z14 = "е") Or (z10 = 16) Or (InStr("гой хой кой", z7) > 0)) Then
                tmp = tmp + "и"
            Else
                tmp = tmp + "ы"
            End If
            tmp = tmp + "мм"
            
            If ((z11 = 6) And (z3 = "ч")) Then
                vsp = (10 * 4 + 2 * z2 - 3)
            Else
                vsp = (10 * z11 + 2 * z2 - 3)
            End If
        
            z14 = z14 + Trim(MidNew(tmp, (vsp), 2))
        End If
    End If
    If (z4 > 0) Then
        'ПадежСл = UCase(Mid(z14, 1, 1)) + Mid(z14, 2) + z6
    Else
        'ПадежСл = z14 + z6
    End If
    ПадежСл = z14 + z6
End Function

Function СтрЗаменить(ByVal Где, Optional ByVal Что, Optional ByVal НаЧто) As String
Dim i
    If Что & "" = "" Then
        СтрЗаменить = Где
        Exit Function
    End If
    i = 1
    While (i)
        i = InStr(i, Где, (Что) & "")
        If (i > 0) Then
            Где = MidNew(Где, 1, i - 1) + НаЧто + MidNew(Где, i + Len((Что & "")))
            i = i + Len(НаЧто & "")
        Else
            i = 0
        End If
    Wend
    СтрЗаменить = Где
End Function

Public Function zPologit(z) As Long
    If z > 0 Then
        zPologit = z
    Else
        zPologit = 1
    End If
End Function

Public Function MidNew(ByVal strBy, ByVal pos As Long, Optional Kol) As String
If pos > 0 Then
    On Error Resume Next
    If Kol >= 0 Then
        MidNew = Mid(strBy, pos, Kol)
    End If
End If
End Function

Public Function LeftNew(ByVal strBy, ByVal pos As Long) As String
If pos > 0 Then
    LeftNew = Left(strBy, pos)
End If
End Function

Public Function ФамИО(strFIO) As String
Dim p_1 As Long, p_2 As Long
    strFIO = strFIO & " "
    strFIO = СтрЗаменить(strFIO, ".", " ") 'если Фам И.О.
    p_1 = InStr(strFIO, " ")
    Dim sIO As String
    sIO = LTrim(Mid(strFIO, p_1))
    p_2 = InStr(sIO, " ")
    strFIO = Trim(Left(strFIO, p_1))
    If Trim(Left(sIO, 1)) <> "" Then
        strFIO = strFIO & " " & Left(sIO, 1) & "."
        If Trim(Mid(sIO, p_2)) <> "" Then
            strFIO = strFIO & " " & Left(Trim(Mid(sIO, p_2)), 1) & "."
        End If
    End If
    ФамИО = strFIO
End Function