---Soumis par Jay Holovacs---

Nom propres avec exceptions.

    Voici un ensemble de fonctions qui permettent de manipuler certaines règles spéciales de noms propres. Étant modulaire, on peut ajouter des règles supplémentaires, si cela est opportun.

Par exemple, en ce moment, les cas suivants sont couverts:

Henry VIIIK.
O'Hara
Tom McHill

Appeler la fonction en lui fournissant la chaîne à transformer, en minuscules (l'argument original n'est pas modifié).

dim retval as string
retval=mixed_case("joe mcdonald")

'************** Code Start *************
'This code was originally written by Jay Holovacs. 
'It is not to be altered or distributed, 
'except as part of an application. 
'You are free to use it in any application,  
'provided the copyright notice is left unchanged.

'Ce code fut originalement écrit par Jay Holovacs. 
'Il ne doit pas être altéré ni distribué hormis
'comme inclus dans une application. 
'Vous êtes libre de l'utiliser dans n'importe quelle application,  
'en autant que vous laissiez cette note inchangée.

'
'Code Courtesy of
'Jay Holovacs
'
Public Function mixed_case(str As Variant) As String
'retourne la chaîne modifiée, comme un nom propre de personne
'
Dim ts As String, ps As Integer, char2 As String
    If IsNull(str) Then
        mixed_case = ""
        Exit Function
    End If
    If Len(str) = 0 Then
        mixed_case = ""
        Exit Function
    End If
    ts = LCase$(str)
    ps = 1
    ps = first_letter(ts, ps)
    special_name ts, 1
    'Commence par une majuscule?
    Mid$(ts, 1) = UCase$(left$(ts, 1))
    If ps = 0 Then
        mixed_case = ts
        Exit Function
    End If
    While ps <> 0
        If is_roman(ts, ps) = 0 Then
            'si ce n'est pas romain, appliquer les autres règles
            special_name ts, ps
            Mid$(ts, ps) = UCase$(Mid$(ts, ps, 1)) 'première lettre en majuscule
        End If
        ps = first_letter(ts, ps)
    Wend
    mixed_case = ts
End Function

Private Sub special_name(str As String, ps As Integer)
    'str une chaîne en minuscules, ps le début où on
    'commencer la vérification, retourne str modifié
    '
    Dim char2 As String
    char2 = Mid$(str, ps, 2) 'vérifie règle spéciales
    If (char2 = "mc" Or char2 = "o'") And Len(str) > ps + 1 Then 'genre Mc 
        Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 1))
    End If
End Sub

Private Function first_letter(str As String, ps As Integer) As Integer
'ps=starting point to search (starts with character AFTER ps)
'returns next first letter, 0 if no more left
Dim p2 As Integer, s2 As String
    s2 = str
    p2 = InStr(ps, str, " ") 'points to next blank, 0 if no more
    If p2 = 0 Then
        first_letter = 0
        Exit Function
    End If
    'first move to first non blank, non punctuation after blank
    While is_alpha(Mid$(str, p2)) = False
        p2 = p2 + 1
        If p2 > Len(str) Then 'we ran off the end
            first_letter = 0
            Exit Function
        End If
    Wend
    first_letter = p2
End Function

Public Function is_alpha(ch As String)
'returns true if this is alphabetic character
'false if not
    Dim c As Integer
    c = Asc(ch)
    Select Case c
        Case 65 To 90
            is_alpha = True
        Case 97 To 122
            is_alpha = True
        Case Else
            is_alpha = False
    End Select
End Function

Private Function is_roman(str As String, ps As Integer) As Integer
'commençant à la position  ps, jusqu'à la fin du mot. Si c'est un nombre
'romain, passer tout le mot en majuscules, autrement
'ne pas modifier la chaîne. Retourner 1 si des changements
'furent apportés, 0 autrement.
Dim mx As Integer, p2 As Integer, flag As Integer, i As Integer
    mx = Len(str) 'jusqu'où aller
    p2 = InStr(ps, str, " ") 'vérifier s'il y a un autre espace après ce mot
    If p2 = 0 Then
        p2 = mx + 1
    End If
    'vérifier s'il n'y a aucun caractère non approprié
    flag = 0
    For i = ps To p2 - 1
        If InStr("ivxIVX", Mid$(str, i, 1)) = 0 Then
            flag = 1
        End If
    Next i
    If flag Then
        is_roman = 0
        Exit Function 'c'est un chiffre romain 
    End If
    Mid$(str, ps) = UCase$(Mid$(str, ps, p2 - ps))
    is_roman = 1
End Function
'************** Code End  *************