You are welcome to copy any of my code and use it as you wish. If it works well for you, I'd appreciate a small donation to my PayPal account (see the link at the bottom of this page):
Proper Case
This function converts an input string into correct proper case (title case) while preserving any included all-uppercase acronyms, as well as Mc and O’ person names. It follows a balanced mix of the various schools of thought for correct proper case. I created this function because of the poor performance of Microsoft Office's TitleCase function.
For example, the following original strings: The FBI story: is it good, and how did it begin?
The story of the iPhone: why McCloud wrote it
BECOME:
Microsoft's built-in TitleCase tool results: The Fbi Story: Is It Good, And How Did It Begin?
The Story Of The Iphone: Why Mccloud Wrote It
While my ProperCase function produces: The FBI Story: Is it Good, and How Did it Begin?
The Story of the iPhone: Why McCloud Wrote It
This VBA code will run in MS Word, Excel, and Access applications 2000 - 2007.
Public Function ProperCase(InputString As String)
'This function converts the input string into correct proper case while preserving
'any included all-uppercase acronymns.
'Copyright 2006-2012 Derrick P. Duehren
'Paypal donations accepted by D@Duehren.com
'Anyone may use this code for any purpose. All I ask is that this copyright statement be included.
If IsNull(InputString) Then
ProperCase = ""
Exit Function
End If
LowerCase = "abcdefghijklmnopqrstuvwxyz"
UpperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
SpecialChar = " " & "'" & ";:(){}[]<>,.?/\|=-_+!@#$%^&*~`" & Chr(13)
SentencePunctuationChar = ".?!:"
InputLength = Len(InputString)
'------------------------------------------------------------------------------------------------------
'Part 1: If the InputString is ALL UPPERCASE, then convert it to all lowercase
'------------------------------------------------------------------------------------------------------
LowerCaseCount = 0
For Index = 1 To InputLength
If InStr(1, LowerCase, Mid(InputString, Index, 1)) > 0 Then
LowerCaseCount = LowerCaseCount + 1
End If
Next
If LowerCaseCount = 0 Then
InputString = StrConv(InputString, vbLowerCase)
Else
ProperCase = InputStrlng
End If
'------------------------------------------------------------------------------------------------------
'Part 2: Convert InputString into proper case
'------------------------------------------------------------------------------------------------------
'Make the first character uppercase
NewString = StrConv(Left(InputString, 1), vbUpperCase)
'Step though remaining characters, evaluating and converting each as needed
For Index = 2 To InputLength
'Get the character that is two-back from the target character
If Index = 2 Then
PrePreChar = "X"
Else
PrePreChar = Mid(InputString, Index - 2, 1)
End If
'Get the character that is one-back from the target character
PreChar = Mid(InputString, Index - 1, 1)
'Get the target character
Char = Mid(InputString, Index, 1)
'Get the character that immediately follows the target character
PostChar = Mid(InputString, Index + 1, 1)
'Evaluate for special cases
'Target character is after a space.
If PreChar = " " Then
NewString = NewString & StrConv(Char, vbUpperCase)
'Target character is part of an 0'... name.
ElseIf PrePreChar & PreChar = "O'" Then
NewString = NewString & StrConv(Char, vbUpperCase)
'Target character is part of a Mc... name.
ElseIf PrePreChar & PreChar = "Mc" Then
NewString = NewString & StrConv(Char, vbUpperCase)
'Target character is part of a contraction.
ElseIf InStr(1, SpecialChar, PrePreChar) = 0 And PreChar = "'" Then
NewString = NewString & StrConv(Char, vbLowerCase)
'Target character is not part of a contraction, but after two special characters.
ElseIf InStr(1, SpecialChar, PrePreChar) And InStr(1, SpecialChar, PreChar) Then
NewString = NewString & StrConv(Char, vbUpperCase)
'Target character is none of the above and after a special character.
ElseIf InStr(1, SpecialChar, PreChar) Then
NewString = NewString & StrConv(Char, vbUpperCase)
'Target character is none of the above and part of an acronym.
ElseIf InStr(1, UpperCase, Char) > 0 And (InStr(1, UpperCase, PreChar) > 0 Or InStr(1, UpperCase, Char) > 0) Then
NewString = NewString & Char
'Target character is none of the above and part of a MultiCapName (VanTuttle).
ElseIf InStr(1, UpperCase, Char) > 0 And (InStr(1, LowerCase, PreChar) > 0 Or InStr(1, LowerCase, PostChar) > 0) Then
NewString = NewString & Char
'Target character is none of the above.
Else
NewString = NewString & StrConv(Char, vbLowerCase)
End If
Next
'------------------------------------------------------------------------------------------------------
'Part 3: Fix case of any short words, as appropriate
'------------------------------------------------------------------------------------------------------
'Define the 'short words'
‘Short verb forms is, are, and be are excluded.
TwoCharUpper = " An º As º At º By º Of º On º In º It º To º Or º Up º " & _
" An, º As, º At, º By, º Of, º On, º In, º It, º To, º Or, º Up, "
TwoCharLower = " an º as º at º by º of º on º in º it º to º or º up º " & _
" an, º as, º at, º by, º of, º on, º in, º it, º to, º or, º up, "
ThreeCharUpper = " And º But º For º Nor º The "
ThreeCharLower = " and º but º for º nor º the "
'Fix all 'a's; If there is a punctuation character, leave A uppercase.
ShortWordAt = InStr(2, Newstring, " A ", vbBinaryCompare)
While ShortWordAt > 0
If Not InStr(1, SentencePunctuationChar, Mid(Newstring, ShortWordAt - 1, 1)) Then
OldString = Newstring
Newstring = Mid(Newstring, 1, ShortWordAt) & "a " & Mid(Newstring, ShortWordAt + 3)
End If
ShortWordAt = InStr(ShortWordAt + 1, Newstring, " A ", vbBinaryCompare)
Wend
'Fix all 2-character short words
For Index = 2 To InputLength - 3
TwoCharAt = InStr(1, TwoCharUpper, Mid(NewString, Index, 4))
If TwoCharAt > 0 And _
InStr(1, SentencePunctuationChar, Mid(NewString, Index - 1, 1)) = 0 Then
NewString = Mid(NewString, 1, Index) & Mid(TwoCharLower, TwoCharAt + 1, 3) & _
Mid(NewString, Index + 4)
End If
Next
'Fix all 3-character short words
For Index = 2 To InputLength - 4
ThreeCharAt = InStr(1, ThreeCharUpper, Mid(NewString, Index, 5))
If ThreeCharAt > 0 And _
InStr(1, SentencePunctuationChar, Mid(NewString, Index - 1, 1)) = 0 Then
NewString = Mid(NewString, 1, Index) & Mid(ThreeCharLower, ThreeCharAt + 1, 4) & _
Mid(NewString, Index + 5)
End If
Next
ProperCase = NewString
End Function
Table to Text
This Word function converts the current table to regular text. It can be handy when forwarding emails with annoying nested tables of content. Assign a button-bar button to it, place your cursor anywhere in the unwanted table, and click the button once for each layer of table you wish to convert.
Sub Table_To_Text()
'October 5, 2008 by Derrick Duehren
'Converts the current table to regular text.
'Handy when forwarding emails with annoying nested tables of content.
On Error GoTo TheEnd
Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
NestedTables:=True
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindAsk
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.HomeKey Unit:=wdLine
TheEnd:
End Sub
Format Veranda (or any font/size/color)
This Word function formats the selected text as Veranda font, size 10, dark blue.
It also senses and warns you if you are in plain text email mode (known to work in MS Outlook
Change the font settings in the function to set other fonts/size/color.
Sub FormatVeranda()
' Macro created August 18, 2008 by Derrick Duehren
' Formats the selected text as Veranda font, size 10, dark blue.
On Error GoTo EH
Selection.Font.Name = "Verdana"
Selection.Font.Size = 10
Selection.Font.Color = wdColorDarkBlue
Exit Sub
EH:
If Err.Number = 4605 Then
msgbox "You need to switch to HTML format for this email."
End If
End Sub
Bulleted List with No Indent
This Word function turns the selected text into a bullet list with no indent.
Sub NoIndent_Bullet_List()
'Turn the selected text into a bullet list with no indent.
With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)
.NumberFormat = ChrW(61623)
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleBullet
.NumberPosition = InchesToPoints(0.25)
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.TabPosition = InchesToPoints(0.5)
.ResetOnHigher = 0
.StartAt = 1
With .Font
.Bold = wdUndefined
.Italic = wdUndefined
.StrikeThrough = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.Shadow = wdUndefined
.Outline = wdUndefined
.Emboss = wdUndefined
.Engrave = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Underline = wdUndefined
.Color = wdUndefined
.Size = wdUndefined
.Animation = wdUndefined
.DoubleStrikeThrough = wdUndefined
.Name = "Symbol"
End With
.LinkedStyle = ""
End With
ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
wdBulletGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _
wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
With Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0.25)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(-0.25)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.ParagraphFormat.TabStops.ClearAll
ActiveDocument.DefaultTabStop = InchesToPoints(0.5)
Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), _
Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
End Sub
Numbered List with No Indent
This Word function turns the selected text into a numbered list with no indent.
Sub NoIndent_Numbers()
' Macro recorded May 6, 2009 by Derrick Duehren
'Turn the selected text into a bullet list with no indent.
With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
.NumberFormat = "%1."
.TrailingCharacter = wdTrailingTab
.NumberStyle = wdListNumberStyleArabic
.NumberPosition = InchesToPoints(0.25)
.Alignment = wdListLevelAlignLeft
.TextPosition = InchesToPoints(0.5)
.TabPosition = InchesToPoints(0.5)
.ResetOnHigher = 0
.StartAt = 1
With .Font
.Bold = wdUndefined
.Italic = wdUndefined
.StrikeThrough = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.Shadow = wdUndefined
.Outline = wdUndefined
.Emboss = wdUndefined
.Engrave = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Underline = wdUndefined
.Color = wdUndefined
.Size = wdUndefined
.Animation = wdUndefined
.DoubleStrikeThrough = wdUndefined
.Name = ""
End With
.LinkedStyle = ""
End With
ListGalleries(wdNumberGallery).ListTemplates(1).Name = ""
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
wdNumberGallery).ListTemplates(1), ContinuePreviousList:=True, ApplyTo:= _
wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
With Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0.25)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(-0.25)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
Selection.ParagraphFormat.TabStops.ClearAll
ActiveDocument.DefaultTabStop = InchesToPoints(0.5)
Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), _
Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), _
Alignment:=wdAlignTabList
End Sub
If this code is of value to you, please consider making a small donation. Thank you.