Macro 1: Find Questionable Words

UPDATE: This post has been amended.  You can find the complete list of writer's macros here.

As part of my everlong quest to help my fellow writers, I will be posting some of the Macros I've provided (I'm a programmer!) to help out with writing.

Here is the first one, and probably the most useful. It searches for all words in a given list (adverbs, overused words, and cliches) and highlights them.

To use:
1. Copy the code below.
2. Open Word.
3. Press Alt+F8 (or go to Tools->Macro->Macros)
4. Click Edit. Microsoft Visual Basic will open.
5. In the project window (upper right), select Normal->Modules->NewMacros
6. Paste the code below into the text pane.
7. Click save and close the Microsoft Visual Basic.

If you want to change the words in any of the lists, feel free to add them. (NOTE: the adverbExList is an exclusion list. The others are inclusions)

'Finds and highlights adverbs, passive phrases, overused words, and cliches
Sub Find_Questionable_Words()

' Highlight specific types of words in current document
On Error GoTo Err_HighlightWords

Application.Run MacroName:="Clear_All_Highlighting"

Dim adverbExList
Dim passiveList
Dim overusedList
Dim clicheList
Dim adverbColor As WdColorIndex
Dim passiveColor As WdColorIndex
Dim overusedColor As WdColorIndex
Dim clicheColor As WdColorIndex

adverbExList = Array("only", "oily", "family", "homily", "Billy", "Sally", "multiply", "imply", "gangly", "apply", "bully", "belly", "silly", "jelly", "holy", "lovely", "holly", "fly", "July", "rely", "reply", "Lilly", "sully", "gully", "prickly", "crawly", "curly", "sly", "ugly", "motherly")
adverbColor = wdYellow

overusedList = Array("about", "all of a sudden", "almost", "appears", "attractive", "begin to", "beginning to", "began to", "close to", "colorful", "crossing", "creeping", "crept", "embarrassing", "even", "eyebrow", "fabulous", "fascinating", "found herself", "found himself", "found his", "found her", "get", "got", "groan", "handsome", "heaved", "hilarious", "just", "just then", "kinda", "kind of", "many", "momentous", "most", "more and more", "nondescript", "occur", "occurs", "powerful", "quite", "rather", "seemed to", "seems to", "seeming to", "show", "shows", "since", "some", "something in", "somewhat", "somehow", "sort of", "stupid", "very", "went")
overusedColor = wdTurquoise

clicheList = Array("the reason for", "past history", "this is why", "end result", "it is possible that", "the possibility exists", "for all intents and purposes", "there is a chance that", "is able to", "has the opportunity to", "past memories", "future plans", "sudden crisis", "terrible tragedy", "as a matter of fact", "quite frankly", "all the time", "white as a sheet", "as soon as possible", "at the very least", "down in the dumps", "in the nick of time", "hat in hand", "keep your mouth shut", "made a run for it", "utilize", "in order to", "the fact that")
clicheColor = wdBrightGreen

'variables
Dim word
Dim rng As Range
Dim excluded As Boolean
Dim story As WdStoryType
Dim oldTrack
Dim oldHighlight
Dim excludeQuotations As Boolean

' Save current settings
oldTrack = ActiveDocument.TrackRevisions
oldHighlight = Options.DefaultHighlightColorIndex
ActiveDocument.TrackRevisions = False
excludeQuotations = MsgBox(Prompt:="Do you want to skip quotations?", Buttons:=vbYesNo + vbDefaultButton2, Title:="Exclude Quotations?")

Options.CheckGrammarAsYouType = True
Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes"
ActiveDocument.Characters(1).InsertBefore Chr(134)

' Iterate through each document section
For Each rng In ActiveDocument.StoryRanges
' Work only with the main body, footnotes and endnotes
story = rng.StoryType
If story <> wdMainTextStory And story <> wdFootnotesStory And story <> wdEndnotesStory Then
GoTo NextRange
End If
' Do the adverb highlighting
rng.Find.ClearFormatting
rng.Find.Replacement.ClearFormatting
With rng.Find
.Text = "<[! ^13]@(ly)>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While rng.Find.Execute(Replace:=wdNone) = True
If rng.Text = "" Then
Exit Do
End If
excluded = False
For Each word In adverbExList
If LCase(rng.Text) = LCase(word) Then
excluded = True
Exit For
End If
Next

If Not excluded Then
' Highlight current selection
rng.HighlightColorIndex = adverbColor
End If
Loop
' Obtain range again
Options.DefaultHighlightColorIndex = passiveColor
rng.WholeStory
' Set rng = ActiveDocument.StoryRanges.Item(story)
' Do passive word highlighting
rng.Find.ClearFormatting
rng.Find.Replacement.ClearFormatting
rng.Find.Forward = True
rng.Find.Wrap = wdFindContinue
rng.Find.Replacement.Highlight = True
rng.Find.Format = True
rng.Find.MatchCase = False
rng.Find.MatchWholeWord = True
rng.Find.MatchWildcards = False
rng.Find.MatchSoundsLike = False
rng.Find.MatchAllWordForms = False
' Do overused word highlighting (outside quotations only)
Options.DefaultHighlightColorIndex = overusedColor
rng.WholeStory
For Each word In overusedList
rng.Find.Text = word
rng.Find.Wrap = wdFindStop
Do While rng.Find.Execute
rng.Select

If excludeQuotations Then
'from our selection point, work backwards. If the first quote is a start quote,_
'we are inside dialogue, so skip it. If first quote I see is an end quote, we _
'are outside the dialogue tag, so highlight it
Do While Not (Selection.Characters(1) = Chr(147) Or Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134))
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Loop

'End Quote or Dagger (start of doc)
If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then
rng.Select
Selection.Range.HighlightColorIndex = clicheColor
End If
Else
Selection.Range.HighlightColorIndex = clicheColor
End If
Loop
Next
' Do misused word/cliche highlighting (only checks outside quotations)
Options.DefaultHighlightColorIndex = clicheColor
rng.WholeStory
For Each word In clicheList
rng.Find.Text = word
rng.Find.Wrap = wdFindStop
Do While rng.Find.Execute
rng.Select

If excludeQuotations Then
'from our selection point, work backwards. If the first quote is a start quote,_
'we are inside dialogue, so skip it. If first quote I see is an end quote, we _
'are outside the dialogue tag, so highlight it
Do While Not (Selection.Characters(1) = Chr(147) Or Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134))
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Loop

'End Quote or Dagger (start of doc)
If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then
rng.Select
Selection.Range.HighlightColorIndex = clicheColor
End If
Else
Selection.Range.HighlightColorIndex = clicheColor
End If
Loop
Next
NextRange:
Next
' Restore saved settings
ActiveDocument.TrackRevisions = oldTrack
ActiveDocument.Characters(1).Delete
Options.DefaultHighlightColorIndex = oldHighlight
Application.Run MacroName:="Replace_Smart_Quotes_With_Straight_Quotes"
'Move cursor to beginning of document
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst
'MsgBox "Word highlighting complete!"
Exit Sub
Err_HighlightWords:
MsgBox Err.Description
End Sub