posted
Fahim's written a macro which can be accessed directly from the current document and which highlights adverbs, passive words, overly used words and cliches/misused words. It runs fairly fast - completed a 90,000+ word document in about 30 seconds.
To use, open Word, go to Tools - Macro - Macros ... and click on the Create button. This should open up the macro editor. Simply copy the above code, paste it in and click the Save button and then close the Macro Editor. You should be done When you want to run it, you go back to Tools - Macro - Macros ... select the FAF_WordHighlighter macro and click the Run button - it will process the currently open document.
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
If you have any problems, you can post it here or on Fahim's forum or email Fahim directly at fahimf at gmail dot com.
posted
Hardcoding the overused words? Ridiculous. Make it count the number of times a word is used (limit it to words at least five letters in length) and use the ten or so most common ones as its list.
Posts: 10645 | Registered: Jul 2004
| IP: Logged |
posted
Go for it, KoM! I'd love to see your macro when you're done!
Seriously, it's much less memory and resource intensive doing it this way rather than taking many passes through the document, counting words, etc.
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.
Posts: 8355 | Registered: Apr 2003
| IP: Logged |
posted
King of Men, you're probably looking at the term "overused words" and commenting from that perspective. But basically, the overused list is a customized list for each writer. We all have certain words that we tend to beat to dath I for instance, use "seem", "apparently" and "quite" quite a lot. That particular list is to track your own favourite overused word usage to see if you're perhaps going over the limit ...
Posts: 136 | Registered: Aug 2003
| IP: Logged |
posted
You could write a macro to do this fairly easily in VBA. The difficulty would be performance in longer documents. (My gut instinct would be to write unique instances of a word root to an external dictionary file, then track count.)
Posts: 37449 | Registered: May 1999
| IP: Logged |
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.
Here's a VBA function that makes an array of all words in a text string and the number of times it's used:
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
Just pass the .Text attribute of a document's range to use on a document.
Posts: 26071 | Registered: Oct 2003
| IP: Logged |
10 -> 10 legs 10 them 11 add 11 but 11 for 11 look 11 with 12 same 13 can 13 need 14 i'll 14 move 14 not 14 point 14 rotation 15 as 15 submodel 16 are 16 because 16 on 17 if 19 now 20 have 21 at 22 want 23 be 26 so 27 will 29 you 31 in 32 of 33 this 35 a 35 we 44 picture 44 that 57 is 63 it 72 and 85 i 112 to 152 219 the
Posts: 1209 | Registered: Dec 2003
| IP: Logged |