Strings: Names with Mixed cases

    This set of functions allow developers to handle special rules of name spellings. It is modular so that additional rules for other nationalities can be easily added.

For example it handles names such as:

Henry VIIIK.
O'Hara
Tom McHill
Mary Smith - Jones

Call the function with the name passed in any state of capitalization, returned value is correctly capitalized (original argument is not modified, making it suitable for use in queries).

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.
'
'Code Courtesy of
'Jay Holovacs
'
Public Function mixed_case(str As Variant) As String
'returns modified string, first character of each word us uppercase
'all others lower case
Dim ts As String, ps As Integer, char2 As String
    If IsNull(str) Then
        mixed_case = ""
        Exit Function
    End If
    str = Trim(str) 'added 11/22/98
    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 'try to fix the beginning
    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 'not roman, apply the other rules
            special_name ts, ps
            Mid$(ts, ps) = UCase$(Mid$(ts, ps, 1)) 'capitalize the first letter
        End If
        ps = first_letter(ts, ps)
    Wend
    mixed_case = ts
End Function
Private Sub special_name(str As String, ps As Integer) 
'expects str to be a lower case string, ps to be the 
'start of name to check, returns str modified in place 
'modifies the internal character (not the initial) 

Dim char2 As String 
char2 = Mid$(str, ps, 2) 'check for Scots Mc 
If (char2 = "mc") And Len(str) > ps + 1 Then '3rd char is CAP 
    Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 1)) 
End If 

char2 = Mid$(str, ps, 2) 'check for ff 
If (char2 = "ff") And Len(str) > ps + 1 Then 'ff form 
    Mid$(str, ps, 2) = LCase$(Mid$(str, ps, 2)) 
End If 

char2 = Mid$(str, ps + 1, 1) 'check for apostrophe as 2nd char 
If (char2 = "'") Then '3rd char is CAP 
    Mid$(str, ps + 2) = UCase$(Mid$(str, ps + 2, 1)) 
End If 

Dim char3 As String 
char3 = Mid$(str, ps, 3) 'check for scots Mac 
If (char3 = "mac") And Len(str) > ps + 1 Then 'Mac form 
    Mid$(str, ps + 3) = UCase$(Mid$(str, ps + 3, 1)) 
End If 

Dim char4 As String 
char4 = Mid$(str, ps, 4) 'check for Fitz 
If (char4 = "fitz") And Len(str) > ps + 1 Then 'Fitz form 
    Mid$(str, ps + 4) = UCase$(Mid$(str, ps + 4, 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
'modified 6/18/99 to handle hyphenated names
Dim p2 As Integer, p3 As Integer, s2 As String
    s2 = str
    p2 = InStr(ps, str, " ") 'points to next blank, 0 if no more
    p3 = InStr(ps, str, "-") 'points to next hyphen, 0 if no more
    If p3 <> 0 Then
        If p2 = 0 Then
            p2 = p3
        ElseIf p3 < p2 Then
            p2 = p3
        End If
    End If
    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
'starts at position ps, until end of word. If it appears to be
'a roman numeral, than the entire word is capped in passed back
'string, else no changes made in string
'returns 1 if changes were made, 0 if no change
Dim mx As Integer, p2 As Integer, flag As Integer, i As Integer
    mx = Len(str) 'just so we don't go off the edge
    p2 = InStr(ps, str, " ") 'see if there is another space after this word
    If p2 = 0 Then
        p2 = mx + 1
    End If
    'scan to see if any inappropriate characters in this word
    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 'this is not roman numeral
    End If
    Mid$(str, ps) = UCase$(Mid$(str, ps, p2 - ps))
    is_roman = 1
End Function
'************** Code End  *************