posted                   

code:

---

  
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 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 = "<[! ]@(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

---

Posts: 8355 | Registered: Apr 2003  |  IP: Logged | 

posted                   

quote:

---

I for instance, use "seem", "apparently" and "quite" quite a lot.

---

Apparently, that would seem to be quite an understatement.

Posts: 8355 | Registered: Apr 2003  |  IP: Logged | 

posted                  

quote:

---

Fahim is working on another macro that will count words, et cetera ad nauseum, but it's not done yet, so this is good enough for now.

---

code:

---

Function GetWordsOccurrences(ByVal Text As String) As Variant()
    Dim re As New RegExp
    Dim ma As Match
    Dim col As New Collection
    Dim ndx As Long
    
    ' the following pattern means that we're looking for a word character (\w)
    ' repeated one or more times (the + suffix), and that occurs on a word
    ' boundary (leading and trailing \b sequences)
    re.Pattern = "\b\w+\b"
    ' search for *all* occurrences
    re.Global = True
    
    ' let's start with an array of 100 elements
    ReDim res(1, 100) As Variant
    
    ' we need this to work with the collection
    On Error Resume Next
    
    For Each ma In re.Execute(Text)
        ' the index in the array where this word should be inserted,
        ' if not already in the array
        ndx = col.Count + 1
        ' attempt to add this to the collection
        col.Add ndx, ma.Value
        ' if no error, this is the first occurrence of the word and the
        ' element in the collection already contains the index of the
        ' corresponding element in the array
        If Err = 0 Then
            ' ensure the array is large enough
            If ndx > UBound(res, 2) Then
                ' if not, add 100 elements
                ReDim Preserve res(1, ndx + 99) As Variant
            End If
            ' insert the word and initialize word count
            res(0, ndx) = ma.Value
            res(1, ndx) = 1
            
        Else
            ' the word is already in the array
            Err.Clear
            ' get the index in the array
            ndx = col(ma.Value)
            ' increment word count
            res(1, ndx) = res(1, ndx) + 1
        End If
    Next
    
    ' trim the result array
    If col.Count Then
        ReDim Preserve res(1, col.Count) As Variant
        GetWordsOccurrences = res
    End If

End Function

---

Posts: 26071 | Registered: Oct 2003  |  IP: Logged |