Request for assessment

[Greg Maxey]

Hello,

Today in the New Users group a person was looking for help with marking
words throughout a document that were defined in the introduction. This
number of defined words could number in the hundreds.

The problem was as such. The object words are bold and in quotes. Other
bold words could appear in the definition e.g.,

"Lease" a legal document binding blah, blah.

Each instance of the defined words that appeared in the text the word in the
text needed to be First Cap and bold.

I figure a good starting point was the MultiWordFindAndReplace macro that
Dough Robbins, Dave Lett and others have contributed to and posted in the
groups.

I figured if I selected the entire list of defined words and definitions
that I could build an array using:

For Each oWord In Selection.Words
If oWord.Font.Bold = True And Asc(oWord.Next) = 34 And Asc(oWord.Next) =
34 Then
ListArray = ListArray & oWord & " "
End If
Next oWord
ListArray = Left(ListArray, Len(ListArray) - 1)
ListArray = Split(ListArray)

This seems to work as it results in an array of all bolded quoted words in
the selection and excluded all other bold and non-bold words.

This seems to take awhile if there are lots of words in the selection. My
first question, Have I made this harder than it needs to be? I hate to use
the phrase "better way" for fear Jonathan is reading , but I am trying to
learn and would appreaciate feedback.

For the actual marking of words in the text I used:

For i = LBound(ListArray) To UBound(ListArray)
myString = ListArray(i)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.Text = myString
On Error GoTo Done
.Replacement.Text = Format(Left(myString, 1), ">") _
& Right(myString, Len(myString) - 1)
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
Next i

Second question. Is there another way to make the first character of the
replacement string a Cap besides the string manipulation that I used?

Here is the whole code:
Public Sub WordMarker()
Dim rngstory As Word.Range
Dim ListArray
Dim oWord As Range
'Create the array by selecting the list of definitions
For Each oWord In Selection.Words
If oWord.Font.Bold = True And Asc(oWord.Next) = 34 And Asc(oWord.Next) =
34 Then
ListArray = ListArray & oWord & " "
End If
Next oWord
ListArray = Left(ListArray, Len(ListArray) - 1)
ListArray = Split(ListArray)
MakeHFValid

For Each rngstory In ActiveDocument.StoryRanges
Do
SearchAndReplaceInStory rngstory, ListArray
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
Dim myString As String
For i = LBound(ListArray) To UBound(ListArray)
myString = ListArray(i)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.Text = myString
On Error GoTo Done
.Replacement.Text = Format(Left(myString, 1), ">") _
& Right(myString, Len(myString) - 1)
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
Next i
Done:
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub

 

[G.G.Yagoda]

Hope you don't mind input from a non-Master.

Most Defined Terms in a legal document are *phrases*, not single words.
(You had no way of knowing this.)

Therefore, the your oWord loop is "close but no cigar." You need a
Wildcard search to find *whole phrases* between two quotes at the
beginning of a paragraph. The code below does just that.

A second problem I encountered was with the Split (ListArray). Not
knowing you were dealing with phrases, you added a space after each
word, which resulted in each word becoming a Defined Term.

Actually, you can use *any* punctuation mark to delimit the array
components. My favorite is the "|" symbol; makes neat little fences
between the phrases.

Concerning the method you used to make the first letter a capital, that
is unnecessary. Reason: when you find the phrase MatchWordsOnly and
replace it with the original definition, the replacement will reflect
the exact upper/lower cases of the definition phrase itself.

Oh, there were two things I was too lazy to do - change curly to
straight quotes if necessary, change it back at the end if nec, and
restore Find and Replace settings at the end.

Thanks for the learning experience. P.S. By private e-mail I'm
sending you a humongous legal document that you can play with to your
heart's content.

BEWARE: Contains MsgBoxes for each step, so practice on only a few
Defined Terms.

Public Sub WordMarker()
Dim rngstory As Word.Range
Dim ListArray As Variant
Dim oWord As Range
Dim i As Long
Dim R As Range
Dim StartTime As Variant, StopTime As Variant, TotalTime As Variant
StartTime = Timer
Set R = ActiveDocument.Range
'You have to get rid of curly quotes, if used, before this operation !
! !
Do
With R.Find
.Text = Chr(13) & """*"""
.MatchWildcards = True
.Execute
If R.Font.Bold Then
R.Start = R.Start + 2
R.End = R.End - 1
MsgBox R.Text, , "Defined Term"
Select Case R.Text
Case Is <> ""
R.Text = Trim(R.Text)
ListArray = ListArray & R.Text & "|"
MsgBox ListArray, , "Current List Array"
End Select
End If
R.End = R.End + 1
R.Start = R.End
End With
Loop While R.Find.Found

ListArray = Left(ListArray, Len(ListArray) - 1)
MsgBox ListArray, , "Final List Array"

ListArray = Split(ListArray, "|")

StopTime = Timer
TotalTime = StopTime - StartTime

MsgBox "Total Defined Terms = " & UBound(ListArray) + 1, , "Total Time
= " & TotalTime & " seconds"

For i = LBound(ListArray) To UBound(ListArray) - 1
MsgBox ListArray(i), , "ListArray (" & i & ")"
Next

MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do
SearchAndReplaceInStory rngstory, ListArray
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'You have to restore curly quotes if necessary ! ! !
'You have to change Find and Replace settings to MatchWholeWord = False
! ! !
End Sub


Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
Dim MyString As String
For i = LBound(ListArray) To UBound(ListArray)
MyString = ListArray(i)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Text = MyString
On Error GoTo Done
.Replacement.Text = MyString
'You don't need to cap the first letter - it's always capped in the
Defined Term
' .Replacement.Text = Format(Left(MyString, 1), ">") &
Right(MyString, Len(MyString) - 1)
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
Next i
Done:
End Sub

Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub

www.ussliberty.org

 

[Greg Maxey]

G.G.

I like it . Thanks

I was working on this thing via newsgroup correspondence with the OP and
didn't really no what he/she wanted. The problem of making the first letter
of the replacement a CAP was solved before I realized that each item in the
Array would already be a CAP and it didn't dawn on me until I saw your
method that it wasn't a problem anymore. I obviously was looking at the
forrest while staring at that tree.

I didn't get you e-mail yet, but I follow everything you did except I am not
too sure about the purpose or utility of this bit:
Select Case R.Text
Case Is <> ""
R.Text = Trim(R.Text)
ListArray = ListArray & R.Text & "|"
MsgBox ListArray, , "Current List Array"
End Select

I see that you are building the phrase list, but why Case Is and Trim
statements?

 

[G.G.Yagoda]

The last iteration of the find loop kept giving a blank string. The
problem was solved by adding Case R.Text <> "".

The R.Text = Trim(R.Text) is to prevent an extra space after the
opening quotation mark or before the closing one. Occasionally they
creep in.

Unfortunately, even if this macro works perfectly it doesn't solve
Mark's problems altogether because there's a *second* kind of Defined
Term which appears randomly in parens instead of in the Defined Terms
section. Example:

.. . . such interests (collectively, "The Brothers' Interests" or "The
Colliers' Interests") . . .

Capturing those Defined Terms will fill many an exasperating hour.

The practice legal doc is in the mail.

 

[Chuck]

Nice coding guys. A couple of caveats based on my experience of trying to
come up with a solution that reliably indexes all defined terms in a document
(haven't succeeded yet, not sure it can be done):

1. As GG mentioned, not all defined terms appear in the definitions section
but further, not all defined terms are necessarily capitalised (they usually
are but not always) and even further not all phrases in quotes are defined
terms. I don't know how to deal with these variations.

2. Some defined terms contain other defined terms: for instance
"Consultant", "Consultant Base Rate", "Consultant's Solicitor" all contain
the defined term "Consultant" but are separate defined terms. Any search
that looks for >Consultant< will pick up that word whether it appears as
Consultant or Consultant Base Rate etc. That might not be such a problem
when simply bolding defined terms (so long as the Find.Text doesn't specify
bold as a condition) but when building an index it would seem to me to be a
deal breaker (eg the use of the word Consultant in Consultant Base Rate
should not be flagged as an instance of the defined term Consultant).

Any thoughts most appreciated...

Chuck

 

[Chuck]

Nice coding guys. A couple of caveats based on my experience of trying to
come up with a solution that reliably indexes all defined terms in a document
(haven't succeeded yet, not sure it can be done):

1. As GG mentioned, not all defined terms appear in the definitions section
but further, not all defined terms are necessarily capitalised (they usually
are but not always) and even further not all phrases in quotes are defined
terms. I don't know how to deal with these variations.

2. Some defined terms contain other defined terms: for instance
"Consultant", "Consultant Base Rate", "Consultant's Solicitor" all contain
the defined term "Consultant" but are separate defined terms. Any search
that looks for >Consultant< will pick up that word whether it appears as
Consultant or Consultant Base Rate etc. That might not be such a problem
when simply bolding defined terms (so long as the Find.Text doesn't specify
bold as a condition) but when building an index it would seem to me to be a
deal breaker (eg the use of the word Consultant in Consultant Base Rate
should not be flagged as an instance of the defined term Consultant).

Any thoughts most appreciated...

Chuck

 

[Greg]

Chuck,

Slow day at work so I spent it cracking my skull working on this issue


For the first part, I think that has to be solved by protocol. (I,e.,
If it a defined term then the draft must include it in the defined
terms/definitions section, If it is a defined term it must be
capitalized, if it is quoted and bold then it is a defined term.)
These are the rules of the game. Play by them or take your ball and go
home "-)


I have adapted the code to both mark and index defined terms. The
unresolved problems is as you mention. I.e., defined terms within
defined terms are index :-( I will post the code and maybe some smart
guy or gal can help us out:
Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
curlyQuotesToggled = False
ActiveWindow.View.ShowHiddenText = False
'Test for curly quotes
Set myRange = ActiveDocument.Range
With myRange.Find
.Text = """*"""
.MatchWildcards = True
.Execute
If Len(myRange.Text) = Len(ActiveDocument.Range) Then quotesAreCurly =
True
End With

If quotesAreCurly Then
Options.AutoFormatAsYouTypeReplaceQuotes = False
curlyQuotesToggled = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Each Defined Term must be preceeded by a paragraph mark.
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = Chr(13) & """*"""
.MatchWildcards = True
.Execute
If myRange.Font.Bold Then
'Strip quotation marks
myRange.Start = myRange.Start + 2
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined
Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Restore curly qoutes
If curlyQuotesToggled Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
Options.AutoFormatAsYouTypeReplaceQuotes = enableSmartQuotes
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
ActiveWindow.View.ShowHiddenText = True
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub

 

[G.G.Yagoda]

Gold stars, Greg.

Chuck - Let's assume for a moment that all Defined Terms could be
captured, regardless of where they appear.

Would you be kind enough to spell out in as much detail as possible the
specific goals you would want to accomplish in your index.

For example:

* Index each page on which a Defined Term appears?
* Index which terms are defined but never used?
* Index which terms are defined more than once and cross-reference the
definitions?
* Accent the terms throughout the document with bold font or some other
font attribute?

What exactly do would you want an index of Defined Terms to do? Or
more precisely, what would the *attys* want?

The specs, please.

 

[Chuck]

Hi Greg and GG

Many thanks for tweaking code to create index markers – great stuff! I hope
you don’t mind if I suggest some modifications?

Regarding how defined terms are delimited – realistically, defined terms are
not always in a definitions section and they aren’t necessarily capitalised
either. Whatever the pros and cons, at the end of the day it comes down to
user compliance: attorneys will not comply with a requirement that defined
terms appear in a definitions section or that they can’t use lower case
defined terms. Furthermore, defined terms aren’t necessarily in unnumbered
paragraphs (sometimes they’re in tables, other times they’re in manually
numbered paragraphs, etc). However, attorneys generally will budge on the
issue of cosmetics (eg bold) when the rationale is explained to them – “if
you want an index, you can have your terms wherever you like and they don’t
have to be initial capped, but they do have to be bold faced to eliminate
text quotations from the indexâ€. So the minimum requirement for defined
terms should be that they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I’d suggest storing
the user’s curly quotes option setting, then replacing all curly quotes with
straight quotes. For searching purposes we need to standardise one way or
the other, so we might as well use straight quotes; also I’ve come across
quite a few instances where curly and straight quotes both appear in a
document for no good reason (as a result of copying text from emails, etc).
[Note that the quotes must be double quotes not single quotes as is common
practice in non-US jurisdictions - single quote delimited defined terms will
not be picked up properly because apostrophes within defined terms will look
like end-of-term delimiters. Attorneys will need to have this explained to
them as a deal breaker.]

I’m not sure the search and replace for curly quotes needs to loop through
story ranges – I tested a curly-to-straight quote replace using
activedocument.range and it got all the instances in headers, footers,
footnotes and endnotes, which are the only ranges that are likely to be of
interest. Not using story ranges for this search speeds things up a little,
yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End – 1
immediately after Execute because often I’ve found that quotes around some
defined terms may be bolded while others aren’t (whether by design or
negligence) – moving those lines accommodates both cases. Also, I changed
the range.start to “+1†from “+2†because defined terms are not always the
first phrase in a paragraph (as mentioned above).

I added code to MakeHFValid to loop through all headers of all sections
although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest testing
whether the user’s curly quotes option setting was set to true; if so, then
restore curly quotes; if not, don’t (to save time).

If curly quotes are restored, I’ve added code to search through all fields
and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it’s done.

As you mentioned, the problem of “defined terms within defined termsâ€
remains. However I think I’ve got a solution. I haven’t coded it because
it’s slightly convoluted and I’m not sure the logic works (although I think
it does).

First modify SearchAndReplaceInStory so that in addition to indexing the
term it applies some attribute that is highly unlikely to be used elsewhere
in the document (such as some very specific RGB colour that someone would
have to work really hard to select precisely from a colour palette). This
allows SearchAndReplaceInStory to skip any instances that match that
attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than once – if
so then it’s a “defined term within a defined term†(eg “Consultant†and
“Consultant’s Solicitorâ€)

3. if a term appears more than once, create another array (Arr2) containing
all terms containing the searched term (eg an array consisting of only
“Consultant†and “Consultant’s Solicitorâ€)

4. use SearchAndReplaceInStory to work through Arr2, starting with the
LONGEST term – so in subsequent iterations shorter versions will be skipped
because they match the exclusion attribute (eg if “Consultant’s Solicitor†is
coloured magenta and SearchAndReplaceInStory skips magenta text, then the
word “Consultant†in “Consultant’s Solicitor†won’t be indexed as an instance
of Consultant which it shouldn’t be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don’t appear more
than once

8. once all the defined terms in Arr1 have been processed, go through the
document to restore original attribute (font colour, whatever) to any text
marked with the SearchAndReplaceInStory exclusion attribute.

Here’s my suggested amended code. Looking forward to your thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[Chuck]

Hi GG

Please see my separate post to Greg and you regarding code.

Regarding what to do with the defined terms once they've been identified,
all of the ideas you mentioned (below) would be great as options.

However the main issue that would need to be addressed before adding bells
and whistles would be how to eliminate duplicate indexing for "defined terms
within defined terms" -- words that are defined terms that appear within
other defined terms eg "Consultant" and Consultant's Solicitor": the word
"Consultant" in "Consultant's Solicitor" should not be indexed as an instance
of the defined term "Consultant".

In my separate post I suggest a possible way to get around that problem and
would be grateful for your thoughts...

Chuck

 

[Greg Maxey]

Chuck,

Forgive me for not return your suggested code marked up. I was working on
the double indexing problem along the same lines you suggested and I think I
have cracked it. The font attribute and a sorted array is what I keyed on
as well. It appears that we don't need two arrays. I found a bit of code
in google groups that I was able to modify to sort the ListArray by length
(longest to shortest). I then ran the main routine to applied a font
attribute and then and IF condition to apply the Index.

I looked at most of your suggestions and agree (if thoroughly tested and
they work) we should adapt them. I was too far into this to make more
change in fear of fouling it up.

Have a look and feel free to post back with your suggestions again if you
don't mind.


Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
curlyQuotesToggled = False
ActiveWindow.View.ShowHiddenText = False

'Test for curly quotes
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to MainTextStory
Set myRange = ActiveDocument.Range
With myRange.Find
.Text = """*"""
.MatchWildcards = True
.Execute
'Presence of curly quotes will results in the found text range being
'equal to the wholestory range so:
If Len(myRange.Text) = Len(ActiveDocument.Range) Then quotesAreCurly =
True
End With



If quotesAreCurly Then
Options.AutoFormatAsYouTypeReplaceQuotes = False
curlyQuotesToggled = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Each Defined Term must be preceeded by a paragraph mark.
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = Chr(13) & """*"""
.MatchWildcards = True
.Execute
If myRange.Font.Bold Then
'Strip quotation marks
myRange.Start = myRange.Start + 2
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")
'Call sort function
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Restore curly qoutes
If curlyQuotesToggled Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
Options.AutoFormatAsYouTypeReplaceQuotes = enableSmartQuotes
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
ActiveWindow.View.ShowHiddenText = True
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub

 

[Greg Maxey]

Chuck,

I believe that with the revised code below that each term that is "BOLD"
will be included in the ListArray regardless of where it appears in
mainstrory text.

I moved and changed. Moving these means the definitions themselves will not
be Indexed. Is that your intention?:

myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1

The curly quotes are causing real problems. I agree with your process, but
even with that there is problems.
If the term is indexed the XE field is inserted immediately after the text.
When the curly quotes are restored, both right and left lean to the left. I
tried to fix this in the find and replace routine, but the process involved
testing for the character following the find range. IF a " then move the
range start 1 character right then insert the XE field. This fixed the
curly quote issue, but wrecked indexing quoted words in REF fields. I can't
get my head around a solution.

I didn't have time to incorporate your other suggestions. Here is the new
revised code. Note the opening line. I figure we can't spilt any future
royalties three ways. You and G.G. seem to know enough about legal matters
to make that contract bullet proof

Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to MainTextStory
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next


'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Each Defined Term must be preceeded by a paragraph mark.
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
' Strip quotation marks here and the the "BOLD" Defined Terms will not be
indexed
' myRange.Start = myRange.Start + 1
' myRange.End = myRange.End - 1
If myRange.Font.Bold Then
' Strip quotation marks here and the the "BOLD" Defined Terms will be
indexed
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
'Call sort function to sort array longest term to shortest term
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Restore curly qoutes
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
ActiveWindow.View.ShowHiddenText = True
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
' put XE field outside quotes. Fixes smart quotes put fails to INDEX
fields
' rngstory.MoveEnd Unit:=wdCharacter, Count:=1
' If rngstory.Text = Chr$(34) Then
' rngstory.MoveEnd Unit:=wdCharacter, Count:=-1
' rngstory.Start = rngstory.Start + 1
' Else
' rngstory.MoveEnd Unit:=wdCharacter, Count:=-1
' End If
On Error Resume Next
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
On Error GoTo 0
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub


--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Greg and GG

Many thanks for tweaking code to create index markers - great stuff!
I hope you don't mind if I suggest some modifications?

Regarding how defined terms are delimited - realistically, defined
terms are not always in a definitions section and they aren't
necessarily capitalised either. Whatever the pros and cons, at the
end of the day it comes down to user compliance: attorneys will not
comply with a requirement that defined terms appear in a definitions
section or that they can't use lower case defined terms.
Furthermore, defined terms aren't necessarily in unnumbered
paragraphs (sometimes they're in tables, other times they're in
manually numbered paragraphs, etc). However, attorneys generally
will budge on the issue of cosmetics (eg bold) when the rationale is
explained to them - "if you want an index, you can have your terms
wherever you like and they don't have to be initial capped, but they
do have to be bold faced to eliminate text quotations from the
index". So the minimum requirement for defined terms should be that
they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I'd suggest
storing the user's curly quotes option setting, then replacing all
curly quotes with straight quotes. For searching purposes we need to
standardise one way or the other, so we might as well use straight
quotes; also I've come across quite a few instances where curly and
straight quotes both appear in a document for no good reason (as a
result of copying text from emails, etc). [Note that the quotes must
be double quotes not single quotes as is common practice in non-US
jurisdictions - single quote delimited defined terms will not be
picked up properly because apostrophes within defined terms will look
like end-of-term delimiters. Attorneys will need to have this
explained to them as a deal breaker.]

I'm not sure the search and replace for curly quotes needs to loop
through story ranges - I tested a curly-to-straight quote replace
using activedocument.range and it got all the instances in headers,
footers, footnotes and endnotes, which are the only ranges that are
likely to be of interest. Not using story ranges for this search
speeds things up a little, yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
immediately after Execute because often I've found that quotes around
some defined terms may be bolded while others aren't (whether by
design or negligence) - moving those lines accommodates both cases.
Also, I changed the range.start to "+1" from "+2" because defined
terms are not always the first phrase in a paragraph (as mentioned
above).

I added code to MakeHFValid to loop through all headers of all
sections although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest testing
whether the user's curly quotes option setting was set to true; if
so, then restore curly quotes; if not, don't (to save time).

If curly quotes are restored, I've added code to search through all
fields and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it's done.

As you mentioned, the problem of "defined terms within defined terms"
remains. However I think I've got a solution. I haven't coded it
because it's slightly convoluted and I'm not sure the logic works
(although I think it does).

First modify SearchAndReplaceInStory so that in addition to indexing
the term it applies some attribute that is highly unlikely to be used
elsewhere in the document (such as some very specific RGB colour that
someone would have to work really hard to select precisely from a
colour palette). This allows SearchAndReplaceInStory to skip any
instances that match that attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than once
- if so then it's a "defined term within a defined term" (eg
"Consultant" and "Consultant's Solicitor")

3. if a term appears more than once, create another array (Arr2)
containing all terms containing the searched term (eg an array
consisting of only "Consultant" and "Consultant's Solicitor")

4. use SearchAndReplaceInStory to work through Arr2, starting with the
LONGEST term - so in subsequent iterations shorter versions will be
skipped because they match the exclusion attribute (eg if
"Consultant's Solicitor" is coloured magenta and
SearchAndReplaceInStory skips magenta text, then the word
"Consultant" in "Consultant's Solicitor" won't be indexed as an
instance of Consultant which it shouldn't be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don't
appear more than once

8. once all the defined terms in Arr1 have been processed, go through
the document to restore original attribute (font colour, whatever) to
any text marked with the SearchAndReplaceInStory exclusion attribute.

Here's my suggested amended code. Looking forward to your thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[Greg Maxey]

Fixed the curly quote issue. They needed to be restored after building the
array and before indexing:
Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to MainTextStory
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Each Defined Term must be preceeded by a paragraph mark.
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
' Strip quotation marks here and the the "BOLD" Defined Terms will not be
indexed
' myRange.Start = myRange.Start + 1
' myRange.End = myRange.End - 1
If myRange.Font.Bold Then
' Strip quotation marks here and the the "BOLD" Defined Terms will be
indexed
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
'Call sort function to sort array longest term to shortest term
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Restore curly qoutes
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Clear bold in TOC entries
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
ActiveWindow.View.ShowHiddenText = True
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
' put XE field outside quotes. Fixes smart quotes put fails to INDEX
fields
' rngstory.MoveEnd Unit:=wdCharacter, Count:=1
' If rngstory.Text = Chr$(34) Then
' rngstory.MoveEnd Unit:=wdCharacter, Count:=-1
' rngstory.Start = rngstory.Start + 1
' Else
' rngstory.MoveEnd Unit:=wdCharacter, Count:=-1
' End If
On Error Resume Next
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
On Error GoTo 0
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub



--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Greg and GG

Many thanks for tweaking code to create index markers - great stuff!
I hope you don't mind if I suggest some modifications?

Regarding how defined terms are delimited - realistically, defined
terms are not always in a definitions section and they aren't
necessarily capitalised either. Whatever the pros and cons, at the
end of the day it comes down to user compliance: attorneys will not
comply with a requirement that defined terms appear in a definitions
section or that they can't use lower case defined terms.
Furthermore, defined terms aren't necessarily in unnumbered
paragraphs (sometimes they're in tables, other times they're in
manually numbered paragraphs, etc). However, attorneys generally
will budge on the issue of cosmetics (eg bold) when the rationale is
explained to them - "if you want an index, you can have your terms
wherever you like and they don't have to be initial capped, but they
do have to be bold faced to eliminate text quotations from the
index". So the minimum requirement for defined terms should be that
they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I'd suggest
storing the user's curly quotes option setting, then replacing all
curly quotes with straight quotes. For searching purposes we need to
standardise one way or the other, so we might as well use straight
quotes; also I've come across quite a few instances where curly and
straight quotes both appear in a document for no good reason (as a
result of copying text from emails, etc). [Note that the quotes must
be double quotes not single quotes as is common practice in non-US
jurisdictions - single quote delimited defined terms will not be
picked up properly because apostrophes within defined terms will look
like end-of-term delimiters. Attorneys will need to have this
explained to them as a deal breaker.]

I'm not sure the search and replace for curly quotes needs to loop
through story ranges - I tested a curly-to-straight quote replace
using activedocument.range and it got all the instances in headers,
footers, footnotes and endnotes, which are the only ranges that are
likely to be of interest. Not using story ranges for this search
speeds things up a little, yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
immediately after Execute because often I've found that quotes around
some defined terms may be bolded while others aren't (whether by
design or negligence) - moving those lines accommodates both cases.
Also, I changed the range.start to "+1" from "+2" because defined
terms are not always the first phrase in a paragraph (as mentioned
above).

I added code to MakeHFValid to loop through all headers of all
sections although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest testing
whether the user's curly quotes option setting was set to true; if
so, then restore curly quotes; if not, don't (to save time).

If curly quotes are restored, I've added code to search through all
fields and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it's done.

As you mentioned, the problem of "defined terms within defined terms"
remains. However I think I've got a solution. I haven't coded it
because it's slightly convoluted and I'm not sure the logic works
(although I think it does).

First modify SearchAndReplaceInStory so that in addition to indexing
the term it applies some attribute that is highly unlikely to be used
elsewhere in the document (such as some very specific RGB colour that
someone would have to work really hard to select precisely from a
colour palette). This allows SearchAndReplaceInStory to skip any
instances that match that attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than once
- if so then it's a "defined term within a defined term" (eg
"Consultant" and "Consultant's Solicitor")

3. if a term appears more than once, create another array (Arr2)
containing all terms containing the searched term (eg an array
consisting of only "Consultant" and "Consultant's Solicitor")

4. use SearchAndReplaceInStory to work through Arr2, starting with the
LONGEST term - so in subsequent iterations shorter versions will be
skipped because they match the exclusion attribute (eg if
"Consultant's Solicitor" is coloured magenta and
SearchAndReplaceInStory skips magenta text, then the word
"Consultant" in "Consultant's Solicitor" won't be indexed as an
instance of Consultant which it shouldn't be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don't
appear more than once

8. once all the defined terms in Arr1 have been processed, go through
the document to restore original attribute (font colour, whatever) to
any text marked with the SearchAndReplaceInStory exclusion attribute.

Here's my suggested amended code. Looking forward to your thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[Greg Maxey]

G.G., Chuck, Others;

Latest draft. I think the grease it hot enough to cook. Thoughts

Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
'Hide XE Field text while processing
ActiveWindow.View.ShowHiddenText = False

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to start of
MainTextStory
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
' Strip quotation marks here and the "BOLD" Defined Terms will not be
indexed
' myRange.Start = myRange.Start + 1
' myRange.End = myRange.End - 1
If myRange.Font.Bold Then
' Strip quotation marks here and the the "BOLD" Defined Terms will be
indexed
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
'Call sort function to sort array longest term to shortest term
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Restore curly qoutes per user option
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Clear bold in TOC entries
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey Unit:=wdStory
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
On Error Resume Next
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
On Error GoTo 0
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub


--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Greg and GG

Many thanks for tweaking code to create index markers - great stuff!
I hope you don't mind if I suggest some modifications?

Regarding how defined terms are delimited - realistically, defined
terms are not always in a definitions section and they aren't
necessarily capitalised either. Whatever the pros and cons, at the
end of the day it comes down to user compliance: attorneys will not
comply with a requirement that defined terms appear in a definitions
section or that they can't use lower case defined terms.
Furthermore, defined terms aren't necessarily in unnumbered
paragraphs (sometimes they're in tables, other times they're in
manually numbered paragraphs, etc). However, attorneys generally
will budge on the issue of cosmetics (eg bold) when the rationale is
explained to them - "if you want an index, you can have your terms
wherever you like and they don't have to be initial capped, but they
do have to be bold faced to eliminate text quotations from the
index". So the minimum requirement for defined terms should be that
they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I'd suggest
storing the user's curly quotes option setting, then replacing all
curly quotes with straight quotes. For searching purposes we need to
standardise one way or the other, so we might as well use straight
quotes; also I've come across quite a few instances where curly and
straight quotes both appear in a document for no good reason (as a
result of copying text from emails, etc). [Note that the quotes must
be double quotes not single quotes as is common practice in non-US
jurisdictions - single quote delimited defined terms will not be
picked up properly because apostrophes within defined terms will look
like end-of-term delimiters. Attorneys will need to have this
explained to them as a deal breaker.]

I'm not sure the search and replace for curly quotes needs to loop
through story ranges - I tested a curly-to-straight quote replace
using activedocument.range and it got all the instances in headers,
footers, footnotes and endnotes, which are the only ranges that are
likely to be of interest. Not using story ranges for this search
speeds things up a little, yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
immediately after Execute because often I've found that quotes around
some defined terms may be bolded while others aren't (whether by
design or negligence) - moving those lines accommodates both cases.
Also, I changed the range.start to "+1" from "+2" because defined
terms are not always the first phrase in a paragraph (as mentioned
above).

I added code to MakeHFValid to loop through all headers of all
sections although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest testing
whether the user's curly quotes option setting was set to true; if
so, then restore curly quotes; if not, don't (to save time).

If curly quotes are restored, I've added code to search through all
fields and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it's done.

As you mentioned, the problem of "defined terms within defined terms"
remains. However I think I've got a solution. I haven't coded it
because it's slightly convoluted and I'm not sure the logic works
(although I think it does).

First modify SearchAndReplaceInStory so that in addition to indexing
the term it applies some attribute that is highly unlikely to be used
elsewhere in the document (such as some very specific RGB colour that
someone would have to work really hard to select precisely from a
colour palette). This allows SearchAndReplaceInStory to skip any
instances that match that attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than once
- if so then it's a "defined term within a defined term" (eg
"Consultant" and "Consultant's Solicitor")

3. if a term appears more than once, create another array (Arr2)
containing all terms containing the searched term (eg an array
consisting of only "Consultant" and "Consultant's Solicitor")

4. use SearchAndReplaceInStory to work through Arr2, starting with the
LONGEST term - so in subsequent iterations shorter versions will be
skipped because they match the exclusion attribute (eg if
"Consultant's Solicitor" is coloured magenta and
SearchAndReplaceInStory skips magenta text, then the word
"Consultant" in "Consultant's Solicitor" won't be indexed as an
instance of Consultant which it shouldn't be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don't
appear more than once

8. once all the defined terms in Arr1 have been processed, go through
the document to restore original attribute (font colour, whatever) to
any text marked with the SearchAndReplaceInStory exclusion attribute.

Here's my suggested amended code. Looking forward to your thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[Chuck]

Thanks for all that work, Greg. Great stuff with the array sorting etc.
I've found a couple of issues and am testing them out, will get back to you
tomorrow ok?

G.G., Chuck, Others;

Latest draft. I think the grease it hot enough to cook. Thoughts

Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
'Hide XE Field text while processing
ActiveWindow.View.ShowHiddenText = False

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to start of
MainTextStory
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
' Strip quotation marks here and the "BOLD" Defined Terms will not be
indexed
' myRange.Start = myRange.Start + 1
' myRange.End = myRange.End - 1
If myRange.Font.Bold Then
' Strip quotation marks here and the the "BOLD" Defined Terms will be
indexed
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
'Call sort function to sort array longest term to shortest term
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined Terms")
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Restore curly qoutes per user option
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Clear bold in TOC entries
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey Unit:=wdStory
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
On Error Resume Next
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
On Error GoTo 0
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub


--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Greg and GG

Many thanks for tweaking code to create index markers - great stuff!
I hope you don't mind if I suggest some modifications?

Regarding how defined terms are delimited - realistically, defined
terms are not always in a definitions section and they aren't
necessarily capitalised either. Whatever the pros and cons, at the
end of the day it comes down to user compliance: attorneys will not
comply with a requirement that defined terms appear in a definitions
section or that they can't use lower case defined terms.
Furthermore, defined terms aren't necessarily in unnumbered
paragraphs (sometimes they're in tables, other times they're in
manually numbered paragraphs, etc). However, attorneys generally
will budge on the issue of cosmetics (eg bold) when the rationale is
explained to them - "if you want an index, you can have your terms
wherever you like and they don't have to be initial capped, but they
do have to be bold faced to eliminate text quotations from the
index". So the minimum requirement for defined terms should be that
they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I'd suggest
storing the user's curly quotes option setting, then replacing all
curly quotes with straight quotes. For searching purposes we need to
standardise one way or the other, so we might as well use straight
quotes; also I've come across quite a few instances where curly and
straight quotes both appear in a document for no good reason (as a
result of copying text from emails, etc). [Note that the quotes must
be double quotes not single quotes as is common practice in non-US
jurisdictions - single quote delimited defined terms will not be
picked up properly because apostrophes within defined terms will look
like end-of-term delimiters. Attorneys will need to have this
explained to them as a deal breaker.]

I'm not sure the search and replace for curly quotes needs to loop
through story ranges - I tested a curly-to-straight quote replace
using activedocument.range and it got all the instances in headers,
footers, footnotes and endnotes, which are the only ranges that are
likely to be of interest. Not using story ranges for this search
speeds things up a little, yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
immediately after Execute because often I've found that quotes around
some defined terms may be bolded while others aren't (whether by
design or negligence) - moving those lines accommodates both cases.
Also, I changed the range.start to "+1" from "+2" because defined
terms are not always the first phrase in a paragraph (as mentioned
above).

I added code to MakeHFValid to loop through all headers of all
sections although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest testing
whether the user's curly quotes option setting was set to true; if
so, then restore curly quotes; if not, don't (to save time).

If curly quotes are restored, I've added code to search through all
fields and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it's done.

As you mentioned, the problem of "defined terms within defined terms"
remains. However I think I've got a solution. I haven't coded it
because it's slightly convoluted and I'm not sure the logic works
(although I think it does).

First modify SearchAndReplaceInStory so that in addition to indexing
the term it applies some attribute that is highly unlikely to be used
elsewhere in the document (such as some very specific RGB colour that
someone would have to work really hard to select precisely from a
colour palette). This allows SearchAndReplaceInStory to skip any
instances that match that attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than once
- if so then it's a "defined term within a defined term" (eg
"Consultant" and "Consultant's Solicitor")

3. if a term appears more than once, create another array (Arr2)
containing all terms containing the searched term (eg an array
consisting of only "Consultant" and "Consultant's Solicitor")

4. use SearchAndReplaceInStory to work through Arr2, starting with the
LONGEST term - so in subsequent iterations shorter versions will be
skipped because they match the exclusion attribute (eg if
"Consultant's Solicitor" is coloured magenta and
SearchAndReplaceInStory skips magenta text, then the word
"Consultant" in "Consultant's Solicitor" won't be indexed as an
instance of Consultant which it shouldn't be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don't
appear more than once

8. once all the defined terms in Arr1 have been processed, go through
the document to restore original attribute (font colour, whatever) to
any text marked with the SearchAndReplaceInStory exclusion attribute.

Here's my suggested amended code. Looking forward to your thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[Greg Maxey]

Chuck,

No problem getting back later. I have no use for the thing so time doens't
matter

I must have been missed something with this bit:

' Strip quotation marks
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space

Is has no effect on wheter or not the actual "BOLD" Defined Terms are index.
Right now all found instances are indexed.
--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Thanks for all that work, Greg. Great stuff with the array sorting
etc. I've found a couple of issues and am testing them out, will get
back to you tomorrow ok?

G.G., Chuck, Others;

Latest draft. I think the grease it hot enough to cook. Thoughts

Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
'Hide XE Field text while processing
ActiveWindow.View.ShowHiddenText = False

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
ActiveDocument.Bookmarks("\startofdoc").Select 'Return to start of
MainTextStory
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
' Strip quotation marks here and the "BOLD" Defined Terms will not
be indexed
' myRange.Start = myRange.Start + 1
' myRange.End = myRange.End - 1
If myRange.Font.Bold Then
' Strip quotation marks here and the the "BOLD" Defined Terms
will be indexed
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)
'Define the array
ListArray = Split(ListArray, "|")
'Call sort function to sort array longest term to shortest term
ListArray = ListSort(ListArray)
MsgBox ("Document contains " & UBound(ListArray) + 1 & " Defined
Terms") 'Validate blank headers and footers (ensure code sequences
to next HF storyrange
MakeHFValid
'Restore curly qoutes per user option
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Clear bold in TOC entries
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next
RestoreTextColor
Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey Unit:=wdStory
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range,
ByRef ListArray As Variant)
Dim i As Long
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Wrap = wdFindStop
.Text = ListArray(i)
While .Execute
With rngstory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngstory.Font.Color <> wdColorBlueGray Then
On Error Resume Next
ActiveDocument.Indexes.MarkEntry Range:=rngstory,
Entry:=Trim(ListArray(i))
On Error GoTo 0
End If
Wend
End With
rngstory.Expand Unit:=wdStory
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer, j As Integer
Dim first As Integer, last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(ListArray)
last = UBound(ListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(ListArray(i)) < Len(ListArray(j)) Then
temp = ListArray(j)
ListArray(j) = ListArray(i)
ListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = ListArray(i)
Next i
ListSort = sortedList
myString = Join(ListSort, "|")
End Function
Sub RestoreTextColor()
Dim rngstory As Word.Range
MakeHFValid
For Each rngstory In ActiveDocument.StoryRanges
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
Next
End Sub


--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Greg and GG

Many thanks for tweaking code to create index markers - great stuff!
I hope you don't mind if I suggest some modifications?

Regarding how defined terms are delimited - realistically, defined
terms are not always in a definitions section and they aren't
necessarily capitalised either. Whatever the pros and cons, at the
end of the day it comes down to user compliance: attorneys will not
comply with a requirement that defined terms appear in a definitions
section or that they can't use lower case defined terms.
Furthermore, defined terms aren't necessarily in unnumbered
paragraphs (sometimes they're in tables, other times they're in
manually numbered paragraphs, etc). However, attorneys generally
will budge on the issue of cosmetics (eg bold) when the rationale is
explained to them - "if you want an index, you can have your terms
wherever you like and they don't have to be initial capped, but they
do have to be bold faced to eliminate text quotations from the
index". So the minimum requirement for defined terms should be that
they appear in quotes and are bolded.

Rather than testing for curly quotes at the beginning, I'd suggest
storing the user's curly quotes option setting, then replacing all
curly quotes with straight quotes. For searching purposes we need
to standardise one way or the other, so we might as well use
straight quotes; also I've come across quite a few instances where
curly and straight quotes both appear in a document for no good
reason (as a result of copying text from emails, etc). [Note that
the quotes must
be double quotes not single quotes as is common practice in non-US
jurisdictions - single quote delimited defined terms will not be
picked up properly because apostrophes within defined terms will
look like end-of-term delimiters. Attorneys will need to have this
explained to them as a deal breaker.]

I'm not sure the search and replace for curly quotes needs to loop
through story ranges - I tested a curly-to-straight quote replace
using activedocument.range and it got all the instances in headers,
footers, footnotes and endnotes, which are the only ranges that are
likely to be of interest. Not using story ranges for this search
speeds things up a little, yes?

When building the defined terms list, I moved
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
immediately after Execute because often I've found that quotes
around some defined terms may be bolded while others aren't
(whether by
design or negligence) - moving those lines accommodates both cases.
Also, I changed the range.start to "+1" from "+2" because defined
terms are not always the first phrase in a paragraph (as mentioned
above).

I added code to MakeHFValid to loop through all headers of all
sections although that may not be necessary.

After the main routine, when restoring curly quotes, I suggest
testing whether the user's curly quotes option setting was set to
true; if
so, then restore curly quotes; if not, don't (to save time).

If curly quotes are restored, I've added code to search through all
fields and change curly quotes in fields to straight quotes.

At the end I added
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
as well as a msgbox to let the user know it's done.

As you mentioned, the problem of "defined terms within defined
terms" remains. However I think I've got a solution. I haven't
coded it because it's slightly convoluted and I'm not sure the
logic works (although I think it does).

First modify SearchAndReplaceInStory so that in addition to indexing
the term it applies some attribute that is highly unlikely to be
used elsewhere in the document (such as some very specific RGB
colour that someone would have to work really hard to select
precisely from a colour palette). This allows
SearchAndReplaceInStory to skip any instances that match that
attribute.

Then using the array of defined terms:

1. sort that array for each term, starting with the shortest

2. filter the array (Arr1) to see if each term appears more than
once
- if so then it's a "defined term within a defined term" (eg
"Consultant" and "Consultant's Solicitor")

3. if a term appears more than once, create another array (Arr2)
containing all terms containing the searched term (eg an array
consisting of only "Consultant" and "Consultant's Solicitor")

4. use SearchAndReplaceInStory to work through Arr2, starting with
the LONGEST term - so in subsequent iterations shorter versions
will be skipped because they match the exclusion attribute (eg if
"Consultant's Solicitor" is coloured magenta and
SearchAndReplaceInStory skips magenta text, then the word
"Consultant" in "Consultant's Solicitor" won't be indexed as an
instance of Consultant which it shouldn't be)

6. repeat steps 2-5 for the rest of Arr1

7. use SearchAndReplaceInStory for any terms in Arr1 that don't
appear more than once

8. once all the defined terms in Arr1 have been processed, go
through the document to restore original attribute (font colour,
whatever) to any text marked with the SearchAndReplaceInStory
exclusion attribute.

Here's my suggested amended code. Looking forward to your
thoughts...

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G.Yagoda
'Suggested amendments by C Henrich

Dim rngstory As Word.Range
Dim ListArray
Dim myRange As Range
Dim enableSmartQuotes As Boolean
Dim quotesAreCurly As Boolean
Dim curlyQuotesToggled As Boolean
Dim oFld As Field

'Stores users AutoCorrect "smart quote" options.
'True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

ActiveWindow.View.ShowHiddenText = False

Options.AutoFormatAsYouTypeReplaceQuotes = False

'Replace all curly quotes with straight ones.
'Note: doc must be conformed before running
'this procedure so all defined terms delimited
'with double quotes (not single quotes as is
'common practice in non-US jurisdictions) -
'single quote delimited defined terms will
'not be picked up properly because apostrophes
'within defined terms will confuse search
CurlyQuoteToggle ActiveDocument.Range

'Build Defined Terms list and create array
Set myRange = ActiveDocument.Range
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
myRange.Start = myRange.Start + 1
myRange.End = myRange.End - 1
If myRange.Font.Bold Then
'Elimate zero length strings and erroneous white space
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
'Add to list
ListArray = ListArray & myRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found

'Clip trailing separator character
ListArray = Left(ListArray, Len(ListArray) - 1)

'Define the array
ListArray = Split(ListArray, "|")

MsgBox ("Document contains " _
& UBound(ListArray) + 1 & _
" Defined Terms ")

'Validate blank headers and footers
'(ensure code sequences to next HF storyrange)

MakeHFValid

'Main routine
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory

'Restore curly qoutes
If enableSmartQuotes = True Then
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
CurlyQuoteToggle rngstory
'Replace curly quotes with straight
'in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each oFld In ActiveDocument.Fields
oFld.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
Exit For
End If
Next oFld
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next rngstory
End If

Application.ScreenUpdating = True
ActiveWindow.View.ShowHiddenText = True

Selection.HomeKey Unit:=wdStory

MsgBox "Defined terms have been indexed.", _
vbOKOnly, _
"Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngstory As Word.Range, _
ByRef ListArray As Variant)

Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey Unit:=wdStory
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
End With
While rngstory.Find.Execute
With rngstory
rngstory.Select
.Collapse Direction:=wdCollapseStart
rngstory.Select
.Find.Execute Replace:=wdReplaceOne
rngstory.Select
.Collapse Direction:=wdCollapseEnd
rngstory.Select
ActiveDocument.Indexes.MarkEntry _
Range:=rngstory, _
Entry:=Trim(ListArray(i))
End With
Wend
rngstory.Expand Unit:=wdStory
Next i

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long
Dim hdrheader As HeaderFooter
Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
For Each hdrheader _
In ActiveDocument.Sections(i).Headers
lngJunk = hdrheader.Range.StoryType
Next hdrheader
Next i

End Sub

Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)

With rngstory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub

 

[G.G.Yagoda]

Hi, Greg and Chuck -

Back to Consultant, Consultant's Base Fee, Consultant's Base Fee
Calculation, or how to guarantee against re-indexing strings within
strings within strings.

Greg's ListSort solution was absolutely ingenious. But I believe
there's an even easier way that was staring at us all the time.

Secret: color *all* terms as they are found in SearchAndReplaceInStory
and search in reverse alphabetical order, Z-A, by using the Step -1
method:

For i = UBound(ListArray) To LBound(ListArray) Step -1
With rngstory.Find . . . etc.

First it will find, color and mark each instance of Consultant's Base
Fee Calculation. Next it will search for Consultant's Base Fee. It
will find that phrase within the first phrase but will skip it because
it's already colored. So it will find, color, and mark only instances
of Consultant's Base Fee. Ditto for Consultant; only those occurrences
of Consultant which aren't colored will be found, colored and marked.

Still playing with the code and it seems to work fine; will post later.
Just wanted to run the concept by you and get your reaction.

 

[Greg Maxey]

G.G.,

I am missing something. Chuck mentioned that some "Defined Terms" where not
located in the definitions section. If that is true, how can you ensure
that:

Consultant
Consultant's Base Fee
Consultant's Base Fee Calculation

is listed in that order in the array before processing in reverse order? It
seems that if Consultant's Base Fee was marked in text following the
definitions section then it would be processed before the other two. A fix
for this of course is back to protocol.

The sort by length routine will always put Consultant's Base Fee
Calculation before the other two. The rest of the current process works
like the method you describe.

 

[Chuck]

Hi Greg and GG

Regarding rights on the program we’ve developed, I vote for making it
available under the GPL (General Public License) which is standard in the
open source world. Here’s a link to a copy of the GPL
(http://www.gnu.org/licenses/gpl.txt) and a link to information about the GPL
(http://www.gnu.org/copyleft/).

Now to the code:

I added a bit of error handling – if there are no defined terms, the sub
restores curly quotes (if applicable) and exits with a message.

I removed the line
ActiveDocument.Bookmarks("\startofdoc").Select
because it’s not necessary for a range.find especially with wrap set to
wdFindContinue.

I also removed the On Error Resume Next – my personal preference is to test
for errors and resolve them specifically. In my experience On Error Resume
Next can mask bugs by skipping over them. Also, I've had trouble with
programs that cause problems by generating errors then resolving them, rather
than testing for situations that cause errors and avoiding them. I tend to
use error handling to identify bugs and flag problems rather than as a
decision processing function.

The following lines need to run before "If myRange.Font.Bold Then"
myRange.Start = myRange.Start + 1
myRange.End = myRange.End – 1
because quotes around defined terms may or may not be bolded themselves.
What matters is that the defined term itself is bolded and surrounded by
quotes (regardless of whether the quotes are bolded). I’ve tested the code
with those lines before the if-bold test and it works fine.

I’ve replaced the curly quotes restore code with the code I suggested to
restore curly quotes (in a separate macro) -- if curly quotes were initially
enabled, and then to change curly quotes in fields to straight quotes. I
also replaced all instances of "CurlyQuote" with "SmartQuote" for consistency
sake.

I ran into endless loops with the new SearchAndReplaceInStory code – it
turns out that collapsing rngstory to end meant that the next search
iteration picked up the search string in the index entry itself. I've added
code that counts the characters in the index entry and moves the end of
rngstory that many characters (plus 2 to account for the extra 2 spaces on
either side of the field code), then collapses to end, to get past the index
entry and that doesn’t loop. In addition, I had to move the line that
colours the found text to BlueGray so that the term and its index entry are
both coloured BlueGray to avoid having shorter defined terms that might be
contained in the index entry field code picked up as defined terms rather
than index entry code (which was happening without the line position change).

Another endless loop occurred if a defined term was in the TOC. I've added
code in SearchAndReplaceInStory to toggle the TOC fields to ShowCodes = True
before the search and replace, then toggle them back to False when search and
replace completes.

One problem that needs to be avoided is running the program on a document
more than once – the defined terms and their index entries will not be
coloured BlueGray so they'll all be reindexed. The program needs to remove
previous index entries before re-indexing. I've added switch text to the
index entry field code to specify that the entry belongs to the
"DefinedTermsIndex" as well as code that strips out the "DefinedTermsIndex"
entries before moving on to indexing. The defined terms index field itself
will have to include the switch \ f “DefinedTermsIndex†.

Lastly I renamed just about all the variables to make naming consistent (fld
for Field, rng for Range, str for String, etc).

Rather than trying to copy and paste individual changes you might want to
copy the whole shebang. Looking forward to comments.

Option Explicit

Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich

Dim rngStory As Word.Range
Dim arrListArray
Dim rngRange As Range
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field

StripPreviousIndexing

'Stores users AutoCorrect "smart quote" _
'options. True if enabled
blnEnableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

'Hide XE Field text while processing
ActiveWindow.View.ShowHiddenText = False

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False

'Return to start of MainTextStory
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
SmartQuoteToggle rngStory
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next

'Build Defined Terms list and create array
Set rngRange = ActiveDocument.Range
Do
With rngRange.Find
'Find Defined Terms
'(terms quoted and in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
rngRange.Start = rngRange.Start + 1
rngRange.End = rngRange.End - 1
If rngRange.Font.Bold Then
'Elimate zero length strings and
'erroneous white space
Select Case rngRange.Text
Case Is <> ""
rngRange.Text = Trim(rngRange.Text)
'Add to list
arrListArray = arrListArray & rngRange.Text & "|"
End Select
End If
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found

'If no defined terms then
'restore curly quotes (if applicable)
'and exit
If arrListArray = "" Then
MsgBox "There are no defined terms " & _
"in this document."
RestoreSmartQuotes (blnEnableSmartQuotes)
Exit Sub
End If

'Clip trailing separator character
arrListArray = Left(arrListArray, Len(arrListArray) - 1)

'Define the array
arrListArray = Split(arrListArray, "|")

'Call sort function to sort array
'longest term to shortest term
arrListArray = ListSort(arrListArray)

MsgBox ("Document contains " & _
UBound(arrListArray) + 1 & _
" defined terms")

'Validate blank headers and footers
MakeHFValid

RestoreSmartQuotes (blnEnableSmartQuotes)

'Main routine
Application.ScreenUpdating = False
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
SearchAndReplaceInStory rngStory, arrListArray
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next

'Clear bold in TOC entries
For Each fldField In ActiveDocument.Fields
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
Exit For
End If
Next

RestoreTextColor

Application.ScreenUpdating = True
'ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey unit:=wdStory

MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

End Sub

Public Sub SearchAndReplaceInStory( _
ByVal rngStory As Word.Range, _
ByRef arrListArray As Variant)

Dim i As Long
Dim fldIndexEntry As Field
Dim fldField As Field

'Show field codes for TOC
'to prevent looping
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Then '13 = TOC
fldField.ShowCodes = True
End If
Next fldField

For i = LBound(arrListArray) To UBound(arrListArray)
Selection.HomeKey unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrListArray(i)
While .Execute
With rngStory

If .Font.Color <> wdColorBlueGray Then
.Text = .Text
.Font.Bold = True
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrListArray(i)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & "\f ""DefinedTermsIndex"" "
End If
.MoveEnd unit:=wdCharacter, _
Count:=fldIndexEntry.Code.Characters.Count + 2
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
.Select
End With
Wend
End With
rngStory.Expand unit:=wdStory
Next i

'Show field codes for TOC
'to prevent looping
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Then '13 = TOC
fldField.ShowCodes = False
End If
Next fldField

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long

lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType

End Sub

Sub SmartQuoteToggle(ByVal rngStory As Word.Range)

With rngStory.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With

End Sub
Function ListSort(arrListArray) As Variant
'Modified from code found in Google Groups

Dim i As Integer, j As Integer
Dim lngFirst As Integer, lngLast As Integer
Dim varTemp As Variant
Dim varSortedList As Variant
Dim strString As String

lngFirst = LBound(arrListArray)
lngLast = UBound(arrListArray)

ReDim varSortedList(lngLast)

For i = lngFirst To lngLast
For j = i + 1 To lngLast
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
varTemp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = varTemp
End If
Next j
Next i

For i = lngFirst To lngLast
varSortedList(i) = arrListArray(i)
Next i

ListSort = varSortedList
strString = Join(ListSort, "|")

End Function

Sub RestoreTextColor()

Dim rngStory As Word.Range

MakeHFValid

For Each rngStory In ActiveDocument.StoryRanges
Do Until (rngStory Is Nothing)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Color = wdColorBlueGray
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
Set rngStory = rngStory.NextStoryRange
Loop
Next

End Sub

Sub RestoreSmartQuotes(ByVal blnEnableSmartQuotes)
'Restores curly quotes then replaces
'curly quotes appearing in fields with
'straight quotes

Dim rngStory As Word.Range
Dim fldField As Field

'Restore curly qoutes
If blnEnableSmartQuotes = True Then
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
'Call SmartQuoteToggle macro
SmartQuoteToggle rngStory
'Restore straight quotes in fields
Options.AutoFormatAsYouTypeReplaceQuotes = False
For Each fldField In ActiveDocument.Fields
fldField.Select
'Need selection find for fields
'range find not available
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute Replace:=wdReplaceAll
End With
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
Exit For
End If
Next fldField
Options.AutoFormatAsYouTypeReplaceQuotes = True
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
End If

End Sub

Sub StripPreviousIndexing()

Dim fldField As Field
Dim rngStory As Range

MakeHFValid

For Each rngStory In ActiveDocument.StoryRanges
Do Until (rngStory Is Nothing)
For Each fldField In rngStory.Fields
If fldField.Type = 4 Then 'Index entry
If Right(fldField.Code.Text, 23) = _
"\f ""DefinedTermsIndex"" " Then
fldField.Delete
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
Next

End Sub

 

[Greg]

Chuck,

I am unable to get your code to work. First an error is generated here
in SearchAndReplaceInStory routine if one of the defined terms is
matched in a header or footer:

.MoveEnd unit:=wdCharacter, _
Count:=fldIndexEntry.Code.Characters.Count + 2

If I remove the matching term the code runs to completion but the
indexing and marking is inconsistent.

I haven't had time to disect everything you have discussed, but it is
not working with sample of text I am using.