Macros

Ok, I'm bored with putting all these together piece-meal, so I just put up the whole big file after the jump/break.

Last Updated: 11/07/14

How do I put this on my machine?

1. Copy all the text in this file (or after the break).
2. Open Microsoft 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 Microsoft Visual Basic.

How do I use these?

In Microsoft Word, press Alt+F8 or go to Tools -> Macro -> Macros. This will show you a list of the available macros. This is the list you should see.

To run any of these, just highlight the one you want and click "run". Be forewarned: some of them will just highlight words, but some of them will alter your document, and I don't know if "undo" will fix it all. Know what you're clicking on before you run it (and there's explanations below). Plus, these are not thoroughly tested--I am not a VB programmer, and I have no beta testers.

HELP! One of your stupid Macros locked up Word!

Press Ctrl+Break to get out of the macro. There's likely a piece of code that's looping forever. Let me know, and I'll try to fix it.

What do all these do?

First, a note: some of these macros actually run other macros that you can't see in the list. I'll list them, and their explanations below. But if you want to make any of these visible--so you can run them separately--remove the word "private" from the beginning of the function name. If you need more info/explanation, leave me a comment. I'm not a technical writer, so I don't know how well I'm explaining this.

And one more thing, these are meant to be run in order. Each one "resets" the highlighting. So if you click "Find Long Sentences", and then "Find Questionable Words", it'll remove all the previous highlighting it did for the long sentences. You aren't supposed to run them all one after the other.

Why? For one, it would turn the document into a piece of modern art with all the colored highlighting. For another, that's too much for a writer to look at all at once. You should concentrate on one phase at a time.

A_Clean_Up_Document

This fixes some common formatting and style errors that are either hard to see, or the fault of Microsoft's infinite wisdom that it knows what you want to do.

1. Put two spaces after each sentence (should be smart enough around the quotes)
2. Replace manual line breaks - if you ever toggle on "view formatting", there should be a little ¶ after each paragraph. However, sometimes there are little left-pointing arrows (↵) instead. These can mess stuff up if you switch font sizes.
3. Replace smart quotes with straight quotes - I hate smart quotes and smart apostrophes. They never align right, and they don't C & P into any other format. Word allows you to turn them off, but if you type doesnt, Word will auto-correct you to doesn’t (with the smart apostrophe) instead of doesn't.

B_Toggle_Grammar_Underline

Right now, this is a no-operation to remind me to turn on my grammar underliner. I have my Word grammar checker set to only find passive voice (and all the other stuff, either the macros will find or Word doesn't do a good job with it). I haven't been able to get the macro right to simply turn on underline grammar, only select passive voice, and recheck the document. So this just pops up a reminder.

To toggle the gramar underline, go to Options->Spelling & Grammar (or Proofing). Check "Mark grammar errors as you type". Click on Settings. Deselect everything except "Passive sentences". Then click "Check document".

C_Calculate_Word_Frequency

Not terribly useful for novels. For short stories, you can find out if you're using a word too often.

D_Count_Exclamation_Points

Too many exclamation points will make you sound like a teen girl writing an email. I think I heard somebody say no more than two to three in a novel. I didn't do highlighting because A) it's not hard to search and find the ! and B) it's hard to find a highlighted exclamation point. They're so thin and all.

E_Find_Long_Sentences

I usually set it to 20 max words for short stories and 23 for novels. Mostly, you're looking for run-ons and comma splices, but also, break up those sentences that are just too damn long. Sentences that list of things, or have distinctive divisions around clauses (like the emdash that J.K. Rowling's fond of) are okay, IMO.

F_Find_Dangerous_Phrases

There are some common "gotchas" that smear the effectiveness of a sentence through passive voice or unnecessary words. The sentence needs to be rewritten to be stronger, use better words, or maybe eliminated altogether. The input box refers to step number 5.

1. Instances of "he/she felt" or "he/she saw" - using this means you're filtering the sentence through someone else's POV, which dilutes the impact. We're not looking for things like "he felt a concrete wall", but "he felt bad". That's the time you should show, not tell. Any characters you write in the input box will be accounted for too (so you can highlight instances of "John felt" or "John saw").
2. Sentences that start with "It" - What you're looking for is when "it" either signifies that you're spoon-feeding info to the reader or not referring to a real subject. "It was raining". What is "it"? The sky? The Earth? The weather? Change these so that there's an actual subject. "Rain fell."
3. Instances of "it was" (and "it wasn't") - usually a sign of restating something obvious.
4. Instances of "there was" or "there were" - this is a variation of "to be" which is not terribly exciting. Indicates you should be using a better verb. (Note: Don't bother searching for the instances of "to be". You'll claw your eyes out after ten pages).
5. Instances of "was being" or "were being" - a clear indicator of passive voice.
6. Instances of "and then", ", and" & ", then" - two separate sentences joined for no reason. Try splitting them.

G_Find_Acronyms_In_Dialogue

Words like Dr., Mr., Lt., etc. are supposed to be written out in dialogue. Traditional acronyms (like CPU, NASA, RAM) are okay.

H_Find_Past_Perfect

Past perfect is "had" and "had been". Clearly, we're not looking for "the machine had a button". We're looking for actions that were completed before something in the past. Look for passive voice.

I_Find_Sentences_That_Begin_The_Same

Looks for repetition. However, this algorithm is kinda buggy. I think it gets all the positive indicators, but also picks up things that aren't sentences. I'm still working on it.

J_Asked_vs_Said
I have a bad habit of making dialogue tags like "What is that?" John said. Especially for rhetorical questions. These should be asked.

K_Find_Present_Participle

Present participle is "was xxxing". It's a continuous action, and often, you should be using "xxx". For example, instead of "he was watching", it should be "he watched". This is more immediate and less wordy. Gerunds are not our friends.

L_Find_Cliche_Words

Looks for overused phrases and meaningless phrases often found in bad writing, like "spin around", "piercing", "needless to say", "down in the dumps", "utilize", "in order to", and so on.

M_Find_You_In_Narrative

Example: You would think that the earth is flat, but it is, in fact, round. That's not good, that's a quick shift into 2nd-person perspective. You could use "One would think..." but that's a bit lazy too. Try for a better subject like "Most people thought..." or "Common knowledge stated the earth..."

N_Find_That

Not my best title. Finds instances of the word "that" which is also one of my crutch words.

O_Find_Single_Quotes

The only time you should be using single quotes is when you're using dialogue inside of dialogue. All other times, use double quotes.

P_Find_Questionable_Adverbs

Probably one of the most useful macros. They say you should search and destroy words that end in -ly. Well, why not let someone else do it? OK, it won't destroy them, but it'll highlight them.

You'll notice in the code that there is an adverb exclusion list (adverbExceptionList). These are the words that are ignored in the adverb search--words like "fly" (verb) or "family" (noun) or "steely" (adjective). If you find some "-ly" words that are not adverbs, add them to this list.

Also note: there will be a prompt to ask you if you want to exclude searching in quotations. That means anything in quotes (dialogue) will be skipped. Because sometimes characters use bad grammar, adverbs, and cliches. And there's no point to highlight all that.

Q_Highlight_Improper_Digits

In narrative, all digits 10 and under should be written out. In dialogue, all digits should be written out.

R_Find_Common_Apostrophe_Errors

Highlights all instances of it's, its, her's, and who's/whose. It's and its are two that, although I know when to use each, I still write the wrong one sometimes. This will point out each one so you can quick review them. What I do is, I read the phrase, and in my head, I read it as it is. If it sounds right, the word should be it's. If not, the word should be its.

Her's is not a real word. It's hers. There's no his's or hi's, so there's no her's.

Who's is a contraction of who is (the equivalent of it's). Whose is the possessive of who (the equivalent of its).

S_Find_Overused_Words

Works much like Find Dangerous Phrases and Find Cliche Words. Looks for bad writing tip-offs like "um", "er", "uh" (unnecessary and wordy), "attractive", "colorful" (telling instead of showing) "begin to", "start to" (only necessary when the action is being interrupted) "found his", "just", "kind of", "many", "seems to", "somehow", "sighed", "glanced" and so on.

X_Convert_Formatting_to_Plain_Text

This is not supposed to be run with the other macros. This is just something I use when I need to convert a work to plain text for e-mail or manuscript formatting. It changes all instances of bold to *asterisks* and italics to _underscores_.

User-Friendliness Tip: Want to Change What Color Things Are Highlighted In?

Not a problem. You'll notice at the top of the file is a list of the valid colors. Just go into any function and put in the color you want. Some functions, especially the multi-step ones, use the same color for each. But each mini-function chooses its own color. So you can make "it's" as dark blue and "its" as teal. Just look for where the current color is used and replace it.

One Last Thought

This is not meant to be an end-all-be-all hunter-killer. Just because it gets highlighted doesn't mean you HAVE to change it. Examine the suspect words and see if they're appropriate, used effectively, and don't need to be replaced by something stronger. If you're in a first draft, and you can remove/change half the stuff that gets highlighted, you're probably doing good. But just because it ends in 'ly' doesn't mean you have to get rid of it. If it works, let it work.

If you have any questions or need clarification, please send me an e-mail or leave a comment. I'll help you AND update this post so that others don't have the same problem. But I can't help anything if I don't know what the problem is. So please don't think twice about dropping a line.

'NOTE: All non-private functions should start with "clear all highlighting" 'wdBlack - don't use 'wdWhite - don't use 'wdGray25 - little light 'wdGray50 - used 'wdPink - used 'wdDarkRed - used 'wdRed - used 'wdDarkYellow - dark 'wdYellow - used 'wdBrightGreen - used 'wdGreen - dark 'wdTeal - dark 'wdTurquoise - used 'wdBlue - dark 'wdDarkBlue 'wdViolet - dark 'Chr(134) = start of document marker † 'Chr(145) = start quote ' 'Chr(146) = end quote ' 'Chr(147) = start quote " 'Chr(148) = end quote " 'Chr(39) = straight quote ' 'Chr(34) = straight quote " 'Puts two spaces after each sentence, replaces manual line breaks with ^p, makes all quotes straight Sub A_Clean_Up_Document() Application.Run MacroName:="Clear_All_Highlighting" Application.Run MacroName:="Put_Two_Spaces_After_Each_Sentence" Application.Run MacroName:="Replace_Manual_Line_Breaks" Application.Run MacroName:="Replace_Smart_Quotes_With_Straight_Quotes" 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight dangerous sentences Sub F_Find_Dangerous_Phrases() Application.Run MacroName:="Clear_All_Highlighting" Application.Run MacroName:="Find_Felt_And_Saw" Application.Run MacroName:="Find_Sentences_That_Start_With_It" Application.Run MacroName:="Find_It_Was" Application.Run MacroName:="Find_There_Was" Application.Run MacroName:="Find_Was_Being" Application.Run MacroName:="Find_And_Then" End Sub 'Finds sentences over X words long - pink Sub E_Find_Long_Sentences() Application.Run MacroName:="Clear_All_Highlighting" Dim totalWords As Integer Dim maxwords As Integer maxwords = 23 totalWords = 0 For Each mySentence In ActiveDocument.Sentences For Each myWord In mySentence.Words SingleWord = Trim(LCase(myWord)) If SingleWord > "a" And SingleWord < "z" Then totalWords = totalWords + 1 End If Next myWord If totalWords > maxwords Then mySentence.Select Selection.MoveEnd Unit:=wdCharacter, Count:=-1 Selection.Range.HighlightColorIndex = wdPink End If totalWords = 0 Next mySentence 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight instances of its and it's and her's - turquoise Sub R_Find_Common_Apostrophe_Errors() Application.Run MacroName:="Clear_All_Highlighting" Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "it's" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdTurquoise Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdTurquoise Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "its" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdTurquoise Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdTurquoise Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "her's" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdTurquoise Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdTurquoise Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "who's" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdTurquoise Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdTurquoise Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "whose" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdTurquoise Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdTurquoise Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Finds and highlights adverbs - yellow Sub P_Find_Questionable_Adverbs() On Error GoTo Err_HighlightWords Application.Run MacroName:="Clear_All_Highlighting" Dim adverbExceptionList Dim adverbColor As WdColorIndex adverbExceptionList = Array("only", "anomaly", "deadly", "partly", "dragonfly", "lily", "firefly", "wriggly", "freakishly", "wooly", "spindly", "comply", "girly", "woolly", "squiggly", "scaly", "underbelly", "friendly", "tingly", "supply", "resupply", "oily", "chilly", "assembly", "burly", "shapely", "early", "daily", "assembly", "bodily", "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", "spritely", "lonely", "sickly", "steely", "melancholy", "wobbly", "godly", "owly", "wily", "apply", "reapply") adverbColor = wdYellow '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 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 adverbExceptionList 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 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 'Finds and highlights overused words - yellow Sub S_Find_Overused_Words() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim overusedList Dim overusedColor As WdColorIndex Dim yes As String yes = "6" overusedList = Array("er", "um", "ah", "uh", "yeah", "hey", "all of a sudden", "almost", "appears", "attractive", "begin to", "beginning to", "began to", "start to", "started to", "starting to", "close to", "colorful", "crossing", "creeping", "crept", "embarrassing", "even", "eyebrow", "fabulous", "fascinating", "found herself", "found himself", "found his", "found her", "groan", "handsome", "hilarious", "just", "just then", "kinda", "kind of", "many", "momentous", "most", "more and more", "nondescript", "occur", "occurs", "powerful", "quite", "seemed to", "seems to", "seeming to", "shows", "showed", "since", "some", "something in", "somewhat", "somehow", "sort of", "very", "went", "sigh", "sighed", "glance", "glanced", "blink", "blinked", "stare", "stared", "look", "looked", "growl", "growled", "rather", "pretty") overusedColor = wdYellow 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight Dim excludeQuotations Dim onlyQuotations ' 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?") If excludeQuotations <> yes Then onlyQuotations = MsgBox(Prompt:="Do you want to do only quotations?", Buttons:=vbYesNo + vbDefaultButton2, Title:="Only Quotations?") End If Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do overused word highlighting Options.DefaultHighlightColorIndex = overusedColor For Each word In overusedList For Each rng In ActiveDocument.StoryRanges rng.Find.Text = word rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select If excludeQuotations = yes 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 = overusedColor End If Else If onlyQuotations = yes Then 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue, so highlight it. If first quote I see is an end quote, we _ 'are outside the dialogue tag, so skip 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 'Start Quote If Selection.Characters(1) = Chr(147) Then rng.Select Selection.Range.HighlightColorIndex = overusedColor End If Else Selection.Range.HighlightColorIndex = overusedColor End If End If Loop Next rng Next word ' 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 End Sub 'Finds and highlights overused words and cliches - yellow Sub L_Find_Cliche_Words() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim clicheList Dim clicheColor As WdColorIndex Dim yes As String yes = "6" clicheColor = wdYellow clicheList = Array("furrow", "furrowed", "very", "the reason for", "past history", "spin around", "spun around", "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", "framed by", "swelling bosom", "heart-shaped face", "set off by", "revealed", "limpid pools", "better than ever", "for some reason", "for some curious reason", "a number of", "as everybody knows", "she didn't know where she was", "he didn't know where he was", "they didn't know where they were", "things were getting out of hand", "it came as no surprise", "it was beyond", _ "needless to say", "without thinking", "lived in the moment", "well in advance", "emotional roller coaster", "little did i know", "little did he know", "little did she know", "little did they know", "to no avail", "did I say that out loud", "not necessarily in that order", "from hell", "on acid", "Houston, we have a problem", "I'm standing right here", "check, please", "check please", "threw up in my mouth", "can't feel my legs", "you do the math", "you had me at", "sigh of relief") 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight Dim excludeQuotations Dim onlyQuotations ' 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?") If excludeQuotations <> yes Then onlyQuotations = MsgBox(Prompt:="Do you want to do only quotations?", Buttons:=vbYesNo + vbDefaultButton2, Title:="Only Quotations?") End If Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do cliche word highlighting Options.DefaultHighlightColorIndex = clicheColor For Each word In clicheList For Each rng In ActiveDocument.StoryRanges rng.Find.Text = word rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select If excludeQuotations = yes 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 If onlyQuotations = yes Then 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue, so highlight it. If first quote I see is an end quote, we _ 'are outside the dialogue tag, so skip 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 'Start Quote If Selection.Characters(1) = Chr(147) Then rng.Select Selection.Range.HighlightColorIndex = clicheColor End If Else Selection.Range.HighlightColorIndex = clicheColor End If End If Loop Next rng Next word ' 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 End Sub 'Count Exclamation points in document Sub D_Count_Exclamation_Points() Application.Run MacroName:="Clear_All_Highlighting" Dim totalExPoints As Integer totalExPoints = 0 For Each myCharacter In ActiveDocument.Characters If myCharacter = "!" Then totalExPoints = totalExPoints + 1 End If Next myCharacter 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst MsgBox ("Total Exclamation Points = " & totalExPoints) End Sub 'Put two spaces at the end of each sentence (corrects for initials and quotations) Private Sub Put_Two_Spaces_After_Each_Sentence() useTwoSpaces = MsgBox(Prompt:="Do you want to put two or one spaces after each sentence? (2 = Yes, 1 = No)", Buttons:=vbYesNo + vbDefaultButton2, Title:="Two Spaces") If useTwoSpaces = "6" Then With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = True .Forward = True .Format = False .Wrap = wdFindContinue .Text = "([.\?\!]) {1,}" .Replacement.Text = "\1 " .Execute Replace:=wdReplaceAll .Text = "([.\!\?]) {3,}([A-Z])" .Replacement.Text = "\1 \2" .Execute Replace:=wdReplaceAll 'This should prevent most cases of improper double spacing 'in names (e.g., F. Lee Bailey, George W. Bush, etc.) .Text = "([!A-Z][A-Z].) ([A-Z])" 'Two spaces between ) and ( .Replacement.Text = "\1 \2" .Execute Replace:=wdReplaceAll End With 'Correct Mr., Dr., etc. With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Mr. " .Replacement.Text = "Mr. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .MatchCase = True .Forward = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Mrs. " .Replacement.Text = "Mrs. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .Format = False .MatchCase = True .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Ms. " .Replacement.Text = "Ms. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Dr. " .Replacement.Text = "Dr. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Lt. " .Replacement.Text = "Lt. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "vs. " .Replacement.Text = "vs. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "P.A. " .Replacement.Text = "P.A. " .Execute Replace:=wdReplaceAll End With With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .MatchCase = True .Format = False .MatchWholeWord = True .Wrap = wdFindContinue .Text = "Ph.D. " .Replacement.Text = "Ph.D. " .Execute Replace:=wdReplaceAll End With Else With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = True .Forward = True .Format = False .Wrap = wdFindContinue .Text = "([.\?\!]) {1,}" .Replacement.Text = "\1 " .Execute Replace:=wdReplaceAll .Text = "([.\!\?]) {3,}([A-Z])" .Replacement.Text = "\1 \2" .Execute Replace:=wdReplaceAll 'This should prevent most cases of improper double spacing 'in names (e.g., F. Lee Bailey, George W. Bush, etc.) .Text = "([!A-Z][A-Z].) ([A-Z])" 'Two spaces between ) and ( .Replacement.Text = "\1 \2" .Execute Replace:=wdReplaceAll End With End If 'Correct ellipses With ActiveDocument.Content.Find .ClearFormatting .Replacement.ClearFormatting .MatchWildcards = False .Forward = True .Format = False .Wrap = wdFindContinue .Text = "... " .Replacement.Text = "... " .Execute Replace:=wdReplaceAll End With End Sub 'Replaces those "enter" arrows with real paragraph marks Private Sub Replace_Manual_Line_Breaks() Dim myStoryRange As Range For Each myStoryRange In ActiveDocument.StoryRanges With myStoryRange.Find .Text = "^l" .Replacement.Text = "^p" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next myStoryRange End Sub 'Replace all instances of smart quotes with straight quotes Private Sub Replace_Smart_Quotes_With_Straight_Quotes() Dim myStoryRange As Range For Each myStoryRange In ActiveDocument.StoryRanges With myStoryRange.Find .Text = Chr(145) .Replacement.Text = Chr(39) .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With myStoryRange.Find .Text = Chr(146) .Replacement.Text = Chr(39) .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With myStoryRange.Find .Text = Chr(147) .Replacement.Text = Chr(34) .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With myStoryRange.Find .Text = Chr(148) .Replacement.Text = Chr(34) .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next myStoryRange End Sub 'Replace all instance of straight quotes with smart quotes - corrects for alignment Private Sub Replace_Straight_Quotes_With_Smart_Quotes() Dim rngstory As word.Range Dim myRange As Range Dim SmartQuote As Boolean Options.AutoFormatAsYouTypeReplaceQuotes = True For Each rngstory In ActiveDocument.StoryRanges Do If rngstory.StoryLength >= 2 Then QuoteToggle rngstory End If Set rngstory = rngstory.NextStoryRange Loop Until rngstory Is Nothing Next rngstory Options.AutoFormatAsYouTypeReplaceQuotes = False End Sub 'Toggle between smart quote and straight quote Private Sub QuoteToggle(ByVal rngstory As word.Range) With rngstory.Find 'quote marks .Text = Chr$(34) .Replacement.Text = Chr$(34) .Execute Replace:=wdReplaceAll 'apostrophe .Text = Chr$(39) .Replacement.Text = Chr$(39) .Execute Replace:=wdReplaceAll End With End Sub 'find sentences that start with the same two words - bright green Sub I_Find_Sentences_That_Begin_The_Same() On Error GoTo LocalError Application.Run MacroName:="Clear_All_Highlighting" Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" 'convert ellipses temporarily With ActiveDocument.Content.Find .Text = "..." .Replacement.Text = "…" .Execute Replace:=wdReplaceAll End With Dim wordsInSentence Dim wholeSentence As String Dim firstWordOfPrevSentence As String Dim firstWordOfCurrentSentence As String Dim isGhostSentence As Boolean Dim tmpWord As String Dim sentenceCtr As Integer Dim wordCtr As Integer sentenceCtr = 1 For Each mySentence In ActiveDocument.Sentences wholeSentence = mySentence 'NOTE: Word sometimes has ghost sentences where it "duplicates" a sentence in the array, usually due to a tab after a period isGhostSentence = Len(removeCharacters(wholeSentence)) <= 0 Or Len(removeCharacters(ActiveDocument.Sentences(sentenceCtr))) <= 0 If Not (isGhostSentence) Then wordsInSentence = Split(mySentence) firstWordOfCurrentSentence = wordsInSentence(0) firstWordOfCurrentSentence = removeCharacters(firstWordOfCurrentSentence) wordcounter = 1 If Not (sentenceCtr = 0) Then 'if not first sentence If (firstWordOfPrevSentence = firstWordOfCurrentSentence) Then 'Highlight first word in CURRENT sentence Do While Not (InStr(removeCharacters(mySentence.Words(wordcounter)), firstWordOfPrevSentence) > 0) 'this is to make sure we're not counting a leading space wordcounter = wordcounter + 1 If (wordcounter <= ActiveDocument.Sentences(sentenceCtr - 1).Words.Count) Then Exit Do End If Loop If (wordcounter <= ActiveDocument.Sentences(sentenceCtr - 1).Words.Count) Then mySentence.Words(wordcounter).Select Selection.Range.HighlightColorIndex = wdBrightGreen End If 'Highlight first word in PREVIOUS sentence wordcounter = 1 Do While Not (InStr(removeCharacters(ActiveDocument.Sentences(sentenceCtr - 1).Words(wordcounter)), firstWordOfPrevSentence) > 0) wordcounter = wordcounter + 1 If (wordcounter <= ActiveDocument.Sentences(sentenceCtr - 1).Words.Count) Then Exit Do End If Loop If (wordcounter <= ActiveDocument.Sentences(sentenceCtr - 1).Words.Count) Then ActiveDocument.Sentences(sentenceCtr - 1).Words(wordcounter).Select Selection.Range.HighlightColorIndex = wdBrightGreen End If End If End If firstWordOfPrevSentence = wordsInSentence(0) firstWordOfPrevSentence = removeCharacters(firstWordOfPrevSentence) End If sentenceCtr = sentenceCtr + 1 Next mySentence 'convert ellipses back With ActiveDocument.Content.Find .Text = "…" .Replacement.Text = "..." .Execute Replace:=wdReplaceAll End With Application.Run MacroName:="Replace_Smart_Quotes_With_Straight_Quotes" 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst LocalError: Dim Msg As String If Err.Number <> 0 Then Msg = "Error # " & Err.Number & " - " & Err.Description MsgBox (Msg) End If End Sub 'find sentences that start with It - light gray Private Sub Find_Sentences_That_Start_With_It() On Error GoTo LocalError 'convert ellipses temporarily With ActiveDocument.Content.Find .Text = "..." .Replacement.Text = "…" .Execute Replace:=wdReplaceAll End With 'convert question marks temporarily With ActiveDocument.Content.Find .Text = "?" .Replacement.Text = Chr(165) .Execute Replace:=wdReplaceAll End With Dim i As Integer Dim saveWord As String Dim sentenceIndex As Integer saveWord = "it" sentenceIndex = 1 lastSentenceFirstWordIndex = 0 For Each mySentence In ActiveDocument.Sentences firstWordFound = False i = 1 Do Until (firstWordFound Or i > mySentence.Words.Count) If i <= mySentence.Words.Count Then tmpWord = Trim(LCase(mySentence.Words(i))) If tmpWord >= "a" And tmpWord <= "z" Then firstWordFound = True If (tmpWord = saveWord) Then mySentence.Words(i).Select If mySentence.Words(i).Characters.Last = " " Then Selection.MoveEnd Unit:=wdCharacter, Count:=-1 End If Selection.Range.HighlightColorIndex = wdGray50 End If Else i = i + 1 End If End If Loop If i <= mySentence.Words.Count Then lastSentenceFirstWordIndex = i End If sentenceIndex = sentenceIndex + 1 Next mySentence 'convert ellipses back With ActiveDocument.Content.Find .Text = "…" .Replacement.Text = "..." .Execute Replace:=wdReplaceAll End With 'convert question marks back With ActiveDocument.Content.Find .Text = Chr(165) .Replacement.Text = "?" .Execute Replace:=wdReplaceAll End With 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst LocalError: Dim Msg As String If Err.Number <> 0 Then Msg = "Error # " & Err.Number & " - " & Err.Description MsgBox (Msg) End If End Sub 'Highlight instances of it was - light gray Private Sub Find_It_Was() Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "it was" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "It was" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight instances of there was / there were - light gray Private Sub Find_There_Was() Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "there was" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "there were" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "There was" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "There were" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight instances of was being / were being - light gray Private Sub Find_Was_Being() Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "was being" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "were being" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "Was being" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "Were being" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight instances of I/he/she saw, I/he/she felt, I/he/she watched and - light gray Private Sub Find_Felt_And_Saw() Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex sPrompt = "Please enter any character names you wish to use (ex. 'John, Mike, Emily') or leave blank" sTitle = "Enter Character Names" sInput = InputBox(sPrompt, sTitle) names = Split(sInput, ",") For Each rng In ActiveDocument.StoryRanges 'felt rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "he felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "He felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "she felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "She felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "I felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop 'saw rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "he saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "He saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "she saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "She saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "I saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop 'watched rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "he watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "He watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "she watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "She watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "I watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop For Each sName In names rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = sName + " saw" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = sName + " felt" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = sName + " watched" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next sName Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Highlight instances of 'and then' - light gray Private Sub Find_And_Then() Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "and then" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop ' rng.Find.ClearFormatting ' rng.Find.Replacement.ClearFormatting 'rng.Find.Forward = True 'rng.Find.Replacement.Highlight = True 'rng.Find.Format = True 'rng.Find.MatchCase = False 'rng.Find.MatchWholeWord = True 'rng.Find.MatchWildcards = True 'rng.Find.MatchSoundsLike = False 'rng.Find.MatchAllWordForms = False 'rng.WholeStory 'rng.Find.Text = ", then" 'rng.Find.Wrap = wdFindStop 'Options.DefaultHighlightColorIndex = wdGray50 'Do While rng.Find.Execute ' rng.Select ' Selection.Range.HighlightColorIndex = wdGray50 'Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Clear all highlighting Private Sub Clear_All_Highlighting() Options.CheckGrammarAsYouType = False Selection.WholeStory Options.DefaultHighlightColorIndex = wdNoHighlight Selection.Range.HighlightColorIndex = wdNoHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Convert instances of italics to underscores and bold to asterisks Sub X_Convert_Formatting_to_Plain_Text() Application.Run MacroName:="Convert_Bold_to_Asterisks" Application.Run MacroName:="Convert_Italics_to_Underscores" Application.Run MacroName:="Convert_Underlines_to_Underscores" 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Convert instances of italics to underlines and bold to asterisks Sub X_Convert_Formatting_to_Manuscript() Application.Run MacroName:="Convert_Bold_to_Asterisks" Application.Run MacroName:="Convert_Italics_to_Underline" 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Convert italicized text to _something_ Private Sub Convert_Italics_To_Underscores() ActiveDocument.Select With Selection.Find .ClearFormatting .Font.Italic = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Forward = True .Wrap = wdFindContinue Do While .Execute With Selection If InStr(1, .Text, vbCr) Then ' Just process the chunk before any newline characters ' We'll pick-up the rest with the next search .Font.Italic = False .Collapse .MoveEndUntil vbCr End If ' Don't bother to markup newline characters (prevents a loop, as well) If Not .Text = vbCr Then .InsertBefore "_" .InsertAfter "_" End If .Font.Italic = False End With Loop End With 'Any bold will end up weird, so hack them back With ActiveDocument.Content.Find .Text = "_" .Font.Bold = True .Replacement.Text = "_" .Replacement.Font.Bold = False .Execute Replace:=wdReplaceAll End With End Sub 'Convert underlined text to _something_ Private Sub Convert_Underlines_To_Underscores() ActiveDocument.Select With Selection.Find .ClearFormatting .Font.Underline = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Forward = True .Wrap = wdFindContinue Do While .Execute With Selection If InStr(1, .Text, vbCr) Then ' Just process the chunk before any newline characters ' We'll pick-up the rest with the next search .Font.Underline = False .Collapse .MoveEndUntil vbCr End If ' Don't bother to markup newline characters (prevents a loop, as well) If Not .Text = vbCr Then .InsertBefore "_" .InsertAfter "_" End If .Font.Underline = False End With Loop End With 'Any bold will end up weird, so hack them back With ActiveDocument.Content.Find .Text = "_" .Font.Bold = True .Replacement.Text = "_" .Replacement.Font.Bold = False .Execute Replace:=wdReplaceAll End With End Sub 'Convert italicized text to underlined text Private Sub Convert_Italics_To_Underline() ActiveDocument.Select With Selection.Find .ClearFormatting .Font.Italic = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Forward = True .Wrap = wdFindContinue Do While .Execute With Selection Selection.Font.Italic = wdToggle Selection.Font.UnderlineColor = wdColorAutomatic Selection.Font.Underline = wdUnderlineSingle End With Loop End With 'Any bold will end up weird, so hack them back With ActiveDocument.Content.Find .Text = "_" .Font.Bold = True .Replacement.Text = "_" .Replacement.Font.Bold = False .Execute Replace:=wdReplaceAll End With End Sub 'Convert bold text to *something* Private Sub Convert_Bold_To_Asterisks() ActiveDocument.Select With Selection.Find .ClearFormatting .Font.Bold = True .Text = "" .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Forward = True .Wrap = wdFindContinue Do While .Execute With Selection If InStr(1, .Text, vbCr) Then ' Just process the chunk before any newline characters ' We'll pick-up the rest with the next search .Font.Bold = False .Collapse .MoveEndUntil vbCr End If ' Don't bother to markup newline characters (prevents a loop, as well) If Not .Text = vbCr Then .InsertBefore "*" .InsertAfter "*" End If .Font.Bold = False End With Loop End With 'Any italic will end up weird, so hack them back With ActiveDocument.Content.Find .Text = "*" .Font.Italic = True .Replacement.Text = "*" .Replacement.Font.Italic = False .Execute Replace:=wdReplaceAll End With End Sub 'Highlight instances of 'was xxxxing' - red Sub K_Find_Present_Participle() Application.Run MacroName:="Clear_All_Highlighting" Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = False rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "was [! ]@ing" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdRed Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdRed Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Toggle Passive Voice auto-highlight Sub B_Toggle_Grammar_Underline() ' If Options.CheckGrammarAsYouType = True Then ' Options.CheckGrammarAsYouType = False ' ActiveDocument.ShowGrammaticalErrors = False ' Else ' Options.CheckGrammarAsYouType = True ' ActiveDocument.ShowGrammaticalErrors = True ' ' 'Do a no-op to trigger the recheck ' With ActiveDocument.Content.Find ' .Text = "e" ' .Replacement.Text = "e" ' .Execute Replace:=wdReplaceAll ' End With 'End If 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst MsgBox "Turn on grammar highlighting -- check for passive voice!" End Sub 'Calculate frequency of words used Sub C_Calculate_Word_Frequency() Const maxwords = 9000 'Maximum unique words allowed Dim SingleWord As String 'Raw word pulled from doc Dim Words(maxwords) As String 'Array to hold unique words Dim Freq(maxwords) As Integer 'Frequency counter for unique words Dim WordNum As Integer 'Number of unique words Dim ByFreq As Boolean 'Flag for sorting order Dim ttlwds As Long 'Total words in the document Dim Excludes As String 'Words to be excluded Dim Found As Boolean 'Temporary flag Dim j, k, l, Temp As Integer 'Temporary variables Dim ans As String 'How user wants to sort results Dim tword As String ' ' Set up excluded words Excludes = "[the][a][of][is][to][for][by][be][and][are]" ' Find out how to sort ByFreq = True ans = InputBox("Sort by WORD or by FREQ?", "Sort order", "WORD") If ans = "" Then End If UCase(ans) = "WORD" Then ByFreq = False End If Selection.HomeKey Unit:=wdStory System.Cursor = wdCursorWait WordNum = 0 ttlwds = ActiveDocument.Words.Count ' Control the repeat For Each aWord In ActiveDocument.Words SingleWord = Trim(LCase(aWord)) 'Out of range? If SingleWord < "a" Or SingleWord > "z" Then SingleWord = "" End If 'On exclude list? If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = "" End If If Len(SingleWord) > 0 Then Found = False For j = 1 To WordNum If Words(j) = SingleWord Then Freq(j) = Freq(j) + 1 Found = True Exit For End If Next j If Not Found Then WordNum = WordNum + 1 Words(WordNum) = SingleWord Freq(WordNum) = 1 End If If WordNum > maxwords - 1 Then j = MsgBox("Too many words.", vbOKOnly) Exit For End If End If ttlwds = ttlwds - 1 StatusBar = "Remaining: " & ttlwds & ", Unique: " & WordNum Next aWord ' Now sort it into word order For j = 1 To WordNum - 1 k = j For l = j + 1 To WordNum If (Not ByFreq And Words(l) < Words(k)) _ Or (ByFreq And Freq(l) > Freq(k)) Then k = l Next l If k <> j Then tword = Words(j) Words(j) = Words(k) Words(k) = tword Temp = Freq(j) Freq(j) = Freq(k) Freq(k) = Temp End If StatusBar = "Sorting: " & WordNum - j Next j ' Now write out the results tmpName = ActiveDocument.AttachedTemplate.FullName Documents.Add Template:=tmpName, NewTemplate:=False Selection.ParagraphFormat.TabStops.ClearAll With Selection For j = 1 To WordNum .TypeText Text:=Trim(Str(Freq(j))) _ & vbTab & Words(j) & vbCrLf Next j End With System.Cursor = wdCursorNormal j = MsgBox("There were " & Trim(Str(WordNum)) & _ " different words ", vbOKOnly, "Finished") End Sub 'Find had or had been Sub H_Find_Past_Perfect() Application.Run MacroName:="Clear_All_Highlighting" Dim rng As Range oldHighlight = Options.DefaultHighlightColorIndex For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "had been" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "had once been" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = True rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False rng.WholeStory rng.Find.Text = "had previously been" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "had" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select Selection.Range.HighlightColorIndex = wdGray50 Loop Next rng Options.DefaultHighlightColorIndex = oldHighlight 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst End Sub 'Find uses of "you" that are not in dialogue Sub M_Find_You_In_Narrative() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim highlightColor As WdColorIndex highlightColor = wdYellow 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight ' Save current settings oldTrack = ActiveDocument.TrackRevisions oldHighlight = Options.DefaultHighlightColorIndex ActiveDocument.TrackRevisions = False Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do overused word highlighting Options.DefaultHighlightColorIndex = highlightColor For Each rng In ActiveDocument.StoryRanges rng.Find.Text = "you" rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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) = narrative If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then rng.Select Selection.Range.HighlightColorIndex = highlightColor End If Loop Next rng For Each rng In ActiveDocument.StoryRanges rng.Find.Text = "your" rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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) = narrative If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then rng.Select Selection.Range.HighlightColorIndex = highlightColor End If Loop Next rng ' 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 End Sub 'Find possible instances of dialogue tags that should be 'asked' and not 'said' Sub J_Find_Asked_vs_Said() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim highlightColor As WdColorIndex highlightColor = wdYellow 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight ' Save current settings oldTrack = ActiveDocument.TrackRevisions oldHighlight = Options.DefaultHighlightColorIndex ActiveDocument.TrackRevisions = False Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do overused word highlighting Options.DefaultHighlightColorIndex = highlightColor For Each rng In ActiveDocument.StoryRanges rng.Find.Text = "?" rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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 'Start quote = dialogue If Selection.Characters(1) = Chr(147) Then rng.Select Do While Not (Selection = "." Or Selection = Chr(147) Or Selection.Range.End + 2 >= ActiveDocument.Range.End) If (Selection.Words(1) = "said" Or Selection.Words(1) = "say" Or Selection.Words(1) = "says") Then Selection.Words(1).HighlightColorIndex = highlightColor End If Selection.MoveRight Unit:=wdCharacter, Count:=1 Loop End If Loop Next rng ' 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 End Sub 'Find instances of "that" - gray Sub N_Find_That() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim yes As String yes = "6" clicheColor = wdGray50 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight Dim excludeQuotations Dim onlyQuotations ' 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?") If excludeQuotations <> yes Then onlyQuotations = MsgBox(Prompt:="Do you want to do only quotations?", Buttons:=vbYesNo + vbDefaultButton2, Title:="Only Quotations?") End If Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do cliche word highlighting Options.DefaultHighlightColorIndex = clicheColor For Each rng In ActiveDocument.StoryRanges rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 rng.WholeStory rng.Find.Text = "that" rng.Find.Wrap = wdFindStop Options.DefaultHighlightColorIndex = wdGray50 Do While rng.Find.Execute rng.Select If excludeQuotations = yes 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 If onlyQuotations = yes Then 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue, so highlight it. If first quote I see is an end quote, we _ 'are outside the dialogue tag, so skip 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 'Start Quote If Selection.Characters(1) = Chr(147) Then rng.Select Selection.Range.HighlightColorIndex = clicheColor End If Else Selection.Range.HighlightColorIndex = clicheColor End If End If Loop Next rng ' 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 End Sub 'Find uses of single quotes not in double quotes Sub O_Find_Single_Quotes() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim quoteList Dim highlightColor As WdColorIndex Dim yes As String quoteList = Array("'", Chr(145), Chr(146)) highlightColor = wdDarkRed 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight ' Save current settings oldTrack = ActiveDocument.TrackRevisions oldHighlight = Options.DefaultHighlightColorIndex ActiveDocument.TrackRevisions = False Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) Options.DefaultHighlightColorIndex = digitColor For Each word In quoteList For Each rng In ActiveDocument.StoryRanges rng.Find.Text = word rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True 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 While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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) = narrative If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then rng.Select If (Selection.Characters(1) = Chr(145)) Then Do While Not (Selection.Characters().Last.Text = Chr(146)) 'MsgBox (Selection.Characters().Last.Text) Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend Loop End If Selection.Range.HighlightColorIndex = highlightColor End If Loop Next rng Next word ' 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 End Sub 'Look for digits in narrative and dialogue 'WARNING: This seems to have a bad time with headers Sub Q_Highlight_Improper_Digits() '10 and under should be written out in narrative 'all digits in dialogue should be written out Application.Run MacroName:="Clear_All_Highlighting" Dim intMsgBoxResult As Integer intMsgBoxResult = MsgBox("Warning: This macro does not like headers or footers. This is a bug I'm working on. To ensure the macro completes properly, click Cancel and remove numbers (like page numbers) from your headers/footers. Otherwise, click OK to continue.", vbOKCancel, "Warning") If intMsgBoxResult = vbCancel Then Exit Sub 'constants Dim digitList Dim digitColor As WdColorIndex Dim yes As String digitList = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10") digitColor = wdYellow 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight ' Save current settings oldTrack = ActiveDocument.TrackRevisions oldHighlight = Options.DefaultHighlightColorIndex ActiveDocument.TrackRevisions = False Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do overused word highlighting Options.DefaultHighlightColorIndex = digitColor For Each word In digitList For Each rng In ActiveDocument.StoryRanges rng.Find.Text = word rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = False rng.Find.MatchWholeWord = False rng.Find.MatchWildcards = False rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False Do While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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) = narrative If Selection.Characters(1) = Chr(148) Or Selection.Characters(1) = Chr(134) Then rng.Select Selection.Range.HighlightColorIndex = digitColor End If 'Start quote = dialogue If Selection.Characters(1) = Chr(147) Then rng.Select Selection.Range.HighlightColorIndex = digitColor End If Loop Next rng Next word ' 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 End Sub 'Look for abbreviations (like Dr. and Mr.) in dialogue Sub G_Find_Abbreviations_In_Dialogue() Application.Run MacroName:="Clear_All_Highlighting" 'constants Dim abbreviationList Dim abbreviationColor As WdColorIndex abbreviationList = Array("Dr.", "Mr.", "Lt.", "Mrs.", "Ms.") abbreviationColor = wdGray50 'variables Dim word Dim rng As Range Dim oldTrack Dim oldHighlight ' Save current settings oldTrack = ActiveDocument.TrackRevisions oldHighlight = Options.DefaultHighlightColorIndex ActiveDocument.TrackRevisions = False Application.Run MacroName:="Replace_Straight_Quotes_With_Smart_Quotes" ActiveDocument.Characters(1).InsertBefore Chr(134) ' Do overused word highlighting Options.DefaultHighlightColorIndex = abbreviationColor For Each word In abbreviationList For Each rng In ActiveDocument.StoryRanges rng.Find.Text = word rng.Find.ClearFormatting rng.Find.Replacement.ClearFormatting rng.Find.Forward = True rng.Find.Replacement.Highlight = True rng.Find.Format = True rng.Find.MatchCase = True rng.Find.MatchWholeWord = True rng.Find.MatchWildcards = False rng.Find.MatchSoundsLike = False rng.Find.MatchAllWordForms = False Do While rng.Find.Execute rng.Select 'from our selection point, work backwards. If the first quote is a start quote,_ 'we are inside dialogue If first quote I see is an end quote, we _ 'are outside the dialogue tag 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 'Start quote = dialogue If Selection.Characters(1) = Chr(147) Then rng.Select Selection.Range.HighlightColorIndex = abbreviationColor End If Loop Next rng Next word ' 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 End Sub 'Find sentences that indicate simultaneous actions - bright green 'Change to "He/She []ed ___ and ____" or "He/she []ed, ____" 'Won't work for present or future tense Sub T_Find_Unsophisticated_Sentences() On Error GoTo LocalError Application.Run MacroName:="Clear_All_Highlighting" 'convert ellipses temporarily With ActiveDocument.Content.Find .Text = "..." .Replacement.Text = "…" .Execute Replace:=wdReplaceAll End With 'convert question marks temporarily With ActiveDocument.Content.Find .Text = "?" .Replacement.Text = Chr(165) .Execute Replace:=wdReplaceAll End With Dim wordCtr As Integer Dim tmpWord As String Dim wordsInSentence Dim wordIdxCtr As Integer Dim pronouns Dim pronounFound As Boolean Dim pastTenseVerbs Dim isPastTenseVerb As Boolean tmpWord = "" pronounFound = False isPastTenseVerb = False pastTenseVerbs = Array("arose", "ate", "awoke", "beat", "became", "began", "bent", "bet", "bid", "bit", "blest", "blew", "bore", "bought", "broadcast", "broke", "brought", "built", "burnt", "came", "caught", "chose", "clapt", "cleft", "clept", "cost", "crept", "cut", "dealt", "did", "dove", "drank", "dreamt", "drest", "drew", "drove", "dug", "dwelt", "fell", "felt", "flew", "forgave", "forgot", "forsook", "found", "froze", "gave", "gilt", "girt", "got", "grew", "had", "heard", "held", "hid", "hit", "hung", "hurt", "kent", "kept", "knelt", "knew", "laid", "lay", "leant", "led", "left", "lent", "let", "lit", "lost", "made", "meant", "met", "paid", "pent", "put", "ran", "rang", "read", "reft", "rent", "rode", "rose", "said", "sang", "sank", "sat", "saw", "sent", "shone", "shook", "shot", "shrank", "shut", "slept", "slipt", "smelt", "snuck", "sold", "spelt", "spent", "split", "spoilt", "spoke", "sprang", "sprung", "stank", "stole", "stood", "stript", "strode", "strove", "stunk", "swam", "swore", _ "taught", "thought", "threw", "told", "took", "tore", "tore", "understood", "vext", "walk", "went", "wept", "woke", "won", "wore", "wove", "wrote", "wrote") sPrompt = "Please enter any character names you wish to use (ex. 'John, Mike, Emily') or leave blank" sTitle = "Enter Character Names" sInput = InputBox(sPrompt, sTitle) names = Split(sInput, ",") blDimensioned = False If (UBound(names) > -1) Then For Each sName In names If blDimensioned = True Then ReDim Preserve pronouns(0 To UBound(pronouns) + 1) As String Else ReDim pronouns(0 To 0) As String blDimensioned = True End If pronouns(UBound(pronouns)) = sName Next sName ReDim Preserve pronouns(0 To UBound(pronouns) + 1) As String pronouns(UBound(pronouns)) = "it" ReDim Preserve pronouns(0 To UBound(pronouns) + 1) As String pronouns(UBound(pronouns)) = "he" ReDim Preserve pronouns(0 To UBound(pronouns) + 1) As String pronouns(UBound(pronouns)) = "she" ReDim Preserve pronouns(0 To UBound(pronouns) + 1) As String pronouns(UBound(pronouns)) = "I" Else pronouns = Array("he", "she", "it", "I") End If For Each mySentence In ActiveDocument.Sentences pronounFound = False isPastTenseVerb = False wordsInSentence = Split(mySentence) tmpWord = wordsInSentence(0) 'First path: if the word ends with -ing If (Right(tmpWord, 3) = "ing") Then 'MsgBox (mySentence) wordIdxCtr = 0 wordsInSentence = Split(mySentence) Do While (wordIdxCtr < UBound(wordsInSentence)) 'See if there's a comma (that's not a quote ender) tmpWord = Trim(LCase(wordsInSentence(wordIdxCtr))) If (InStr(tmpWord, ",") > 0 And InStr(tmpWord, Chr(34)) < 1) Then 'See if phrase after the comma starts with he/she/it/or a name wordIdxCtr = wordIdxCtr + 1 tmpWord = Trim(LCase(wordsInSentence(wordIdxCtr))) For Each sPronoun In pronouns If (tmpWord = Trim(LCase(sPronoun))) Then pronounFound = True End If Next sPronoun If (pronounFound) Then 'If so, see if the word after it ends in 'ed' wordIdxCtr = wordIdxCtr + 1 Do While (wordIdxCtr < UBound(wordsInSentence)) tmpWord = Trim(LCase(wordsInSentence(wordIdxCtr))) For Each sVerb In pastTenseVerbs If (tmpWord = Trim(LCase(sVerb))) Then isPastTenseVerb = True End If Next sVerb If (Len(tmpWord) > 2) Then If (Mid(tmpWord, Len(tmpWord) - 1) = "ed" Or isPastTenseVerb) Then mySentence.Select Selection.MoveEnd Unit:=wdCharacter, Count:=-1 Selection.Range.HighlightColorIndex = wdPink wordIdxCtr = UBound(wordsInSentence) End If End If wordIdxCtr = wordIdxCtr + 1 Loop End If End If wordIdxCtr = wordIdxCtr + 1 Loop End If 'Second path: if sentence starts with "As" If (Trim(LCase(tmpWord)) = "as") Then 'MsgBox (mySentence) wordIdxCtr = 1 'Check if second word is a pronoun tmpWord = Trim(LCase(wordsInSentence(wordIdxCtr))) For Each sPronoun In pronouns If (tmpWord = Trim(LCase(sPronoun))) Then pronounFound = True End If Next sPronoun If (pronounFound) Then 'check if 3rd word (or next non-adverb word) is past tense verb wordIdxCtr = wordIdxCtr + 1 Do While (wordIdxCtr < UBound(wordsInSentence)) tmpWord = Trim(LCase(wordsInSentence(wordIdxCtr))) For Each sVerb In pastTenseVerbs If (InStr(tmpWord, Trim(LCase(sVerb))) > 0) Then isPastTenseVerb = True End If Next sVerb If (Len(tmpWord) > 2) Then If (Mid(tmpWord, Len(tmpWord) - 1) = "ed" Or isPastTenseVerb) Then mySentence.Select Selection.MoveEnd Unit:=wdCharacter, Count:=-1 Selection.Range.HighlightColorIndex = wdPink wordIdxCtr = UBound(wordsInSentence) 'get out of while loop End If End If wordIdxCtr = wordIdxCtr + 1 Loop End If End If Next mySentence 'convert ellipses back With ActiveDocument.Content.Find .Text = "…" .Replacement.Text = "..." .Execute Replace:=wdReplaceAll End With 'convert question marks back With ActiveDocument.Content.Find .Text = Chr(165) .Replacement.Text = "?" .Execute Replace:=wdReplaceAll End With 'Move cursor to beginning of document Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst LocalError: Dim Msg As String If Err.Number <> 0 Then Msg = "Error # " & Err.Number & " - " & Err.Description MsgBox (Msg) End If End Sub Private Function removeCharacters(InString As String) As String Dim intLoopCounter As Integer Dim intStringLength As Integer Dim intASCIIVal As Integer intStringLength = Len(InString) InString = LCase(InString) For intLoopCounter = 1 To intStringLength intASCIIVal = Asc(Mid(InString, intLoopCounter, 1)) If intASCIIVal >= 97 And intASCIIVal <= 122 Then removeCharacters = removeCharacters + Mid(InString, intLoopCounter, 1) End If Next intLoopCounter End Function

Labels: macros, Microsoft Word, writing tools