Stephen’s Scribble Pad

[Code sample updated to fix bugs on 21/06/2009]

I use Titlecase a lot in business documents so I was never quite satisfied with the “dumb” version available by default in MS Word which just capitalises the first letter of every word.

After researching some of the conventional rules for Titlecase I started building a Visual Basic procedure to apply these to the Selection in Word. It was a struggle to get it to a state where the rules were correctly applied and then after running some tests another major obstacle reared it’s ugly head: paragraph and character formatting were being lost.

It eventually dawned on me that I should be using the Word Object Model. After some more research lo and behold the awesome power of the Selection.Words.Item object which breaks down the selection to “words” where punctuation and symbols are nicely treated as separate “words” themselves.

To speed things up and for a more visually appealing implementation I turned ScreenUpdating off. It runs at approximately 1 second for 100 words consisting of 500 characters. You really shouldn’t be Titlecasing very large blocks of text so this is fine for most cases.

Sub TitleCase()
Application.ScreenUpdating = False
Dim a, b, c, d, e, f, g, h, p1, p2, pc, wc, x As Integer
Dim Exceptions, Pre1, Pre2, Suf1, Suf2 As Variant
Dim WorkStr As String
Dim myDup() As Object
Dim myRange As Object
Dim mySelection As Object
Dim myIndex()
'
' RULES APPLIED:
' =============
' Rule 1: Always Titlecase the first and last word of the title.
' Rule 2: Lowercase all prepositions of 4 or fewer letters.
' Rule 3: Lowercase all articles (a, an, the).
' Rule 4: Lowercase all coordinate conjunctions (and, but, for, nor, or,
' so, yet).
' Rule 5: Lowercase the second word in compound words if it is a preposition.
'
' RULES NOT APPLIED:
' =================
' Rule 6: Never use periods or exclamation marks.
' Rule 7: Lowercase the "to" in an infinitive, e.g. "to Be" (requires
' grammar check which is beyond the scope of this Subroutine).
'
Exceptions = Array("A", "An", "The", "And", "But", "Or", "Nor", _
"Amid", "As", "At", "Atop", "But", "By", "Down", "For", "From", "In", _
"Into", "Like", "Mid", "Near", "Next", "Of", "Off", "On", "Onto", "Out", _
"Over", "Pace", "Past", "Per", "Plus", "Save", "So", "Than", "Till", _
"To", "Up", "Upon", "Via", "With", "Yet")
e = UBound(Exceptions)
Pre1 = Array(" ", "(", "[", "{ ", "-", " ", " ", " ", Chr(34), Chr(145), _
Chr(147))
Suf1 = Array(" ", ", ", ")", "]", ":", ";", "/", "}", Chr(34), Chr(146), _
Chr(148))
p1 = UBound(Pre1)
Pre2 = Array(". ", "! ", "? ", ". ")
Suf2 = Array(" ", ", ", "; ", ": ")
p2 = UBound(Pre2)
pc = Selection.Paragraphs.Count
wc = Selection.Words.Count
ReDim myDup(pc - 1)
ReDim myIndex(wc - 1)
Set myRange = Selection.Range
Set mySelection = Selection

For x = 0 To pc - 1
Set myDup(x) = Selection.Paragraphs(x + 1).Format.Duplicate
Next x
'
' Convert each Word in the Selection Object to Titlecase to begin with
'
For x = 1 To wc
myRange.Select ' This is needed - after each iteration the Selection is dropped
d = mySelection.Words.Item(x).Text
myIndex(x - 1) = Len(d)
WorkStr = WorkStr & StrConv(d, vbProperCase)
Next x

If wc = 2 Then GoTo SkipRules
'
' Scan and replace according to the above Rules
'
For a = 0 To e
For b = 0 To p1
For c = 0 To p1
'
' Lowercase prepositions, articles, conjunctions and the second word
' in compound words if it is a preposition
'
WorkStr = Replace(WorkStr, Pre1(b) & Exceptions(a) & Suf1(c), Pre1(b) _
& LCase(Exceptions(a)) & Suf1(c))
Next c
Next b

For b = 0 To p2
For c = 0 To p2
'
' Fix captitalisation of prepositions, articles and conjunctions found
' at the beginning of sentences
'
WorkStr = Replace(WorkStr, Pre2(b) & LCase(Exceptions(a)) & Suf2(c), _
Pre2(b) & Exceptions(a) & Suf2(c))

Next c
Next b
Next a
SkipRules:
'
' Write the correctly cased Words back to the Selection. By writing text
' values back to the Text Property of the Words Item Object ensures
' that all character formatting is retained
'
For x = 1 To wc
f = myIndex(x - 1)
g = Left(WorkStr, f)
h = Len(WorkStr)
WorkStr = Right(WorkStr, h - f)
myRange.Select
mySelection.Words.Item(x).Text = g
Next x

For x = 0 To pc - 1
Selection.Paragraphs(x + 1).Format = myDup(x)
Next x

Application.ScreenUpdating = True
End Sub