Attribute VB_Name = "Module1"
Dim Chr(32) As String
Option Compare Text ' ! ( )
Private Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
'
' : sSurname - , sName - , sPatronymic -
Application.Volatile True '
sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")
On Error Resume Next
If sName$ = "" And sPatronymic$ = "" Then
arr = Split(Application.Trim(sSurname$))
sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")
End If
' : "" "" - , - .
Dim bMaleSex As Boolean: ' bMaleSex = (Right(sPatronymic, 1) = "" Or Right(sPatronymic, 4) = "")
bMaleSex = Not (Right(sPatronymic, 2) = "" Or Right(sPatronymic, 4) = "")
If Len(sSurname) > 0 Then '
arrSurname = Split(sSurname, "-")
For i = LBound(arrSurname) To UBound(arrSurname) ' ,
sRes = "": sSurnamePart = arrSurname(i)
If bMaleSex Then '
Select Case Right(sSurnamePart, 1)
Case "", "", "", "", "", "", "": sRes = sSurnamePart
Case "", "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
Case "", "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart
Case Else: sRes = sSurnamePart & ""
End Select
Select Case Right(sSurnamePart, 2) ' ,
Case "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
If LCase(sSurnamePart) Like "*[]" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
If LCase(sSurnamePart) Like "*[!][!]" Then sRes = sSurnamePart & ""
Case "", "", "": sRes = sSurnamePart
Case "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
Case "", "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
If Right(sSurnamePart, 3) = "" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
Case "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
End Select
Else '
Select Case Right(sSurnamePart, 1)
Case "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", _
"", "", "", "", "", "", "", "", "", "", "": sRes = sSurnamePart
Case "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & ""
Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
End Select
Select Case Right(sSurnamePart, 2) ' ,
Case "", "", "": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & ""
End Select
End If
' , -, -, -, -, -, -, -,
' -
If LCase(sSurnamePart) Like "*[]" Then sRes = sSurnamePart
arrSurname(i) = sRes
Next
DativeCase = Join(arrSurname, "-") & " " '
End If
If Len(sName) > 0 Then '
NameException$ = GetDativeException(sName)
If Len(NameException$) Then ' -
DativeCase = DativeCase & NameException$
Else '
If bMaleSex Then
Select Case Right(sName, 1)
Case "", "": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & ""
Case "", "": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & ""
Case "": DativeCase = DativeCase & sName
Case Else: DativeCase = DativeCase & sName & ""
End Select
Else
Select Case Right(sName, 1)
Case "", ""
If Mid(sName, Len(sName) - 1, 1) = "" Then
DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & ""
Else
DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & ""
End If
Case "": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & ""
Case Else: DativeCase = DativeCase & sName
End Select
End If
End If
DativeCase = DativeCase & " "
End If
If Len(sPatronymic) > 0 Then '
If Right(sPatronymic, 4) = "" Or Right(sPatronymic, 4) = "" Then
DativeCase = DativeCase & sPatronymic
Else
If bMaleSex Then
DativeCase = DativeCase & sPatronymic & ""
Else
DativeCase = DativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & ""
End If
End If
End If
DativeCase = Replace(DativeCase, "-", "- ")
DativeCase = StrConv(DativeCase, vbProperCase)
DativeCase = Replace(DativeCase, "- ", "-")
End Function
Private Function GetDativeException(ByVal txt$) As String ' -
Select Case txt$
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "ϸ": GetDativeException = ""
'
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
Case "": GetDativeException = ""
' ( ) -
Case "", "": GetDativeException = txt$
End Select
End Function
Function (FIO$) As String
' = DativeCase(FIO$)
'
If = "" Then
= Chr(32)
End If
=
End Function
