Word's TitleCase function is a fairly blunt instrument that crudely capitalises the first letter of each word and destroys the capitalisation for acronyms and various surnames, for example. Such an approach really doesn't conform to the usual understanding title casing.
The following function will apply a true title case to whatever string you feed into it. Note the comments as to what the optional parameters do.
Code:
Function TitleCase(StrTxt As String, Optional bCaps As Boolean, Optional bClos As Boolean, Optional bExcl As Boolean) As String
'Convert an input string to proper-case.
'Surnames like O', Mc & Mac and hyphenated names are converted to title case also.
'If bCaps = True, then upper-case strings like ABC are preserved; otherwise they're converted.
'If bClos = False, words in the exclusion list after closing characters are retained as lower-case; otherwise they're converted.
'If bExcl = True, words in the exclusion list are retained as lower-case, unless after specified punctuation marks.
Dim i As Long, j As Long, k As Long, l As Long, bFnd As Boolean
Dim StrChr As String, StrExcl As String, StrMac As String, StrPunct As String, StrTmpA As String, StrTmpB As String
'General exclusion list.
StrExcl = "(a),a,am,an,and,are,as,at,(b),be,but,by,(c),can,cm,(d),did,do,does,(e),eg,en,eq,etc,(f),for," & _
"(g),get,go,got,(h),has,have,he,her,him,how,(i),ie,if,in,into,is,it,its,(j),(k),(l),(m),me,mi," & _
"mm,my,(n),na,nb,no,not,(o),of,off,ok,on,one,or,our,out,(p),(q),(r),re,(s),she,so,(t),the," & _
"their,them,they,this,to,(u),(v),via,vs,(w),was,we,were,who,will,with,would,(x),(y),yd,you,your,(z)"
'Mac name lower-case list.
StrMac = "Macad,Macau,Macaq,Macaro,Macass,Macaw,Maccabee,Macedon,Macerate,Mach,Mack,Macle,Macrame,Macro,Macul,Macumb"
StrPunct = "!,;,:,.,?,/,(,{,[,<,“,"""
If bClos = True Then StrPunct = StrPunct & ",),},],>,”"
If bExcl = False Then
StrExcl = ""
StrPunct = ""
Else
StrExcl = " " & Replace(Trim(StrExcl), ",", " , ") & " "
End If
If Len(Trim(StrTxt)) = 0 Then
TitleCase = StrTxt
Exit Function
End If
If bCaps = False Then StrTxt = LCase(StrTxt)
StrTxt = " " & StrTxt & " "
For i = 1 To UBound(Split(StrTxt, " ")) - 1
StrTmpA = Split(StrTxt, " ")(i)
'Check for a double-quote before the word
If Left(StrTmpA, 1) Like "[""“”]" Then
StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
Else
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
End If
StrTmpB = " " & StrTmpB & " "
StrTmpA = " " & StrTmpA & " "
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next
'Code for handling hyphenated words
For i = 1 To UBound(Split(StrTxt, "-"))
StrTmpA = Split(StrTxt, "-")(i)
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next
'Code for handling family names starting with O'
For i = 1 To UBound(Split(StrTxt, "'"))
If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Or _
Right(Split(StrTxt, "'")(i - 1), 2) = Right(Split(StrTxt, "'")(i - 1), 1) Then
StrTmpA = Split(StrTxt, "'")(i)
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
End If
Next
'Code for handling family names starting with Mc
If Left(StrTxt, 2) = "Mc" Then
Mid(StrTxt, 3, 1) = UCase(Mid(StrTxt, 3, 1))
End If
i = InStr(StrTxt, " Mc") + InStr(StrTxt, """Mc")
If i > 0 Then
Mid(StrTxt, i + 3, 1) = UCase(Mid(StrTxt, i + 3, 1))
End If
'Code for handling family names starting with Mac
If InStr(1, StrTxt, "Mac", vbBinaryCompare) > 0 Then
For i = 1 To UBound(Split(StrTxt, " "))
StrTmpA = Split(StrTxt, " ")(i)
If InStr(1, StrTmpA, "Mac", vbBinaryCompare) > 0 Then
StrTmpA = Left(StrTmpA, Len(StrTmpA) - InStr(1, StrTmpA, "Mac", vbBinaryCompare) + 1)
bFnd = False
For j = 0 To UBound(Split(StrMac, ","))
StrTmpB = Split(StrMac, ",")(j)
If Left(StrTmpA, Len(StrTmpB)) = StrTmpB Then
bFnd = True
Exit For
End If
Next
If bFnd = False Then
If Len(Split(Trim(StrTmpA), " ")(0)) > 4 Then
StrTmpB = StrTmpA
Mid(StrTmpB, 4, 1) = UCase(Mid(StrTmpB, 4, 1))
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
End If
End If
End If
Next
End If
'Code to restore excluded words to lower case
If StrExcl <> "" Then
For i = 0 To UBound(Split(StrExcl, ","))
StrTmpA = Split(StrExcl, ",")(i)
StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
If InStr(StrTxt, StrTmpB) > 0 Then
StrTxt = Replace(StrTxt, StrTmpB, StrTmpA)
'Make sure an excluded words following punctution marks are given proper case anyway
For j = 0 To UBound(Split(StrPunct, ","))
StrChr = Split(StrPunct, ",")(j)
StrTxt = Replace(StrTxt, StrChr & StrTmpA, StrChr & StrTmpB)
Next
End If
Next
End If
TitleCase = Trim(StrTxt)
End Function
To re-format just a selection, you could call the function with a macro like:
Code:
Sub MakeTitle()
Application.ScreenUpdating = False
Dim StrTmp As String
With Selection.Range
StrTmp = Trim(.Text)
While Right(StrTmp, 1) = "."
StrTmp = Left(StrTmp, Len(StrTmp) - 1)
Wend
While InStr(StrTmp, " ") > 0
StrTmp = Replace(StrTmp, " ", " ")
Wend
StrTmp = TitleCase(StrTmp, bCaps:=False, bExcl:=False)
.Text = StrTmp
End With
Application.ScreenUpdating = True
End Sub
To re-format all text in the 'Heading 1' Style, you could call the function with a macro like:
Code:
Sub HeadingMakeTitle()
Application.ScreenUpdating = False
Dim StrTmp As String
With ActiveDocument.Range
With .Find
.MatchWildcards = True
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
.Style = "Heading 1"
.Text = "[!^13]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found
StrTmp = Trim(.Text)
While Right(StrTmp, 1) = "."
StrTmp = Left(StrTmp, Len(StrTmp) - 1)
Wend
While InStr(StrTmp, " ") > 0
StrTmp = Replace(StrTmp, " ", " ")
Wend
StrTmp = TitleCase(StrTmp, bCaps:=False, bExcl:=False)
.Text = StrTmp
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
|