Option Compare Text


Sub FAF_WordHighlighter()
'
' WordHighlighter Macro
' Highlight specific types of words in current document
On Error GoTo Err_HighlightWords

	Dim adverbExList
	Dim passiveList
	Dim overusedList
	Dim clicheList
	Dim adverbColor As WdColorIndex
	Dim passiveColor As WdColorIndex
	Dim overusedColor As WdColorIndex
	Dim clicheColor As WdColorIndex
	' *** Modify the following section to configure ***
	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" _
		)
	adverbColor = wdYellow
	passiveList = Array("is", "isn't", "am", "are", "aren't", "was", _
		"wasn't", "were", "will", "would", "won't", "has", _
		"had", "have", "be", "been", "do", "don't", _
		"did", "didn't", "does", "doesn't", "by", "being" _
		)
	passiveColor = wdPink
	overusedList = Array("seem", "seems", "exist", "exists", "appears", _
		"make", "makes", "show", "shows", "occur", "occurs", "get", _
		"got", "went", "put", "some", "many", "most", "that", "very", _
		"extremely", "totally", "completely", "wholly", "utterly", _
		"quite", "rather", "slightly", "fairly", "somewhat", _
		"suddenly", "all of a sudden" _
		)
	overusedColor = wdTurquoise
	clicheList = Array("kind of", "sort of", "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" _
		)
	clicheColor = wdBrightGreen
	' *** do not modify code beyond this point
	' if you don't know what you're doing ***
	
	'variables
	Dim word
	Dim rng As Range
	Dim excluded As Boolean
	Dim story As WdStoryType
	Dim oldTrack
	Dim oldHighlight
	' Save current settings
	oldTrack = ActiveDocument.TrackRevisions
	oldHighlight = Options.DefaultHighlightColorIndex
	ActiveDocument.TrackRevisions = False
	' 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 rng.Text = 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
		For Each word In passiveList
			rng.Find.Text = word
			rng.Find.Execute Replace:=wdReplaceAll
		Next
		' Do overused word highlighting
		Options.DefaultHighlightColorIndex = overusedColor
		rng.WholeStory
		For Each word In overusedList
			rng.Find.Text = word
			rng.Find.Execute Replace:=wdReplaceAll
		Next
		' Do misused word/cliche highlighting
		Options.DefaultHighlightColorIndex = clicheColor
		rng.WholeStory
		For Each word In clicheList
			rng.Find.Text = word
			rng.Find.Execute Replace:=wdReplaceAll
		Next
NextRange:
	Next
	' Restore saved settings
	ActiveDocument.TrackRevisions = oldTrack
	Options.DefaultHighlightColorIndex = oldHighlight
	MsgBox "Word highlighting complete!"
	Exit Sub
Err_HighlightWords:
	MsgBox Err.Description
End Sub