Request for assessment

[Greg]

Chuck,

I am leaving the rights issue to you or G.G. I know that either of you
would be fair.

I am posting back "my" version of our code for evaluation. My version
has two
SearchAndReplaceInStory routines an A and B. The A version is closer to
what we had prevsiously while the B is closer to yours.

For your thoughts.

Word will not index in text boxes, comments or headers and footers.
That is the purpose of the error handler in my version. In your
version I added a IF statement to bypass INDEX field insertion IF the
storyType was 4 or above (in Word2000 that is comments, text boxes and
all headers and footers) 1-3 is maintext footnotes endnotes.

I also don't see the need for "DefinedTermsIndex". I added code to
show field codes for both TOC and INDEX prior to indexing. That way
when the document is reindexed the actual terms are hidden.

I still have one nagging problem that I haven't been able to resolve.
If a word or term is bookmarked and then a REF field is used to that
bookmark the Indexing field overwrites the bookmark and then a Error is
generated in the REF field. The work around now is to ensure the
bookmark is extended to include the space after the term. Then things
work. I need to work that out. Any ideas:

Here is the code. You can switch back and forth between A and B to see
which will work best:

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 oFld As Field

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

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
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 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
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, "|")
'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
RestoreSmartQuotes
End If
'Main routine
Application.ScreenUpdating = False
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
'SearchAndReplaceInStoryA rngStory, ListArray 'My Version

SearchAndReplaceInStoryB rngStory, ListArray 'Chuck's Version
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 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 = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim 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
'See the result
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
Sub StripPreviousIndexing()
Dim oFld As Field
Dim rngStory As Range

MakeHFValid
For Each rngStory In ActiveDocument.StoryRanges
Do Until (rngStory Is Nothing)
For Each oFld In rngStory.Fields
If oFld.Type = 4 Then
'If oFld.Type = wdFieldIndex Or oFld.Type = wdFieldIndexEntry
Then 'Index entry
oFld.Delete
End If
Next oFld
Set rngStory = rngStory.NextStoryRange
Loop
Next
End Sub
Sub RestoreSmartQuotes()
'Restores smart quotes then replaces smart quotes appearing in fields
with
'straight quotes
Dim rngStory As Word.Range
Dim oFld As Field
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 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 Sub
Public Sub SearchAndReplaceInStoryA(ByVal rngStory As Word.Range, _
ByRef ListArray As Variant)
Dim i As Long
Dim oFldIndexEntry As Field
Dim oFld As Field
'Show field codes for TOC to prevent looping
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = True
End If
Next oFld

For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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

'Show field codes for TOC to prevent looping
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = False
End If
Next oFld

End Sub
Public Sub SearchAndReplaceInStoryB( _
ByVal rngStory As Word.Range, _
ByRef ListArray As Variant)
Dim i As Long
Dim oFldIndexEntry As Field
Dim oFld As Field
'Show field codes for TOC to prevent looping
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = True
End If
Next oFld
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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
If rngStory.StoryType < 4 Then
Set oFldIndexEntry =
ActiveDocument.Indexes.MarkEntry(Range:=rngStory, _
Entry:=Trim(ListArray(i)))
oFldIndexEntry.Code.Text = oFldIndexEntry.Code.Text & "\f
""DefinedTermsIndex"" "
rngStory.MoveEnd unit:=wdCharacter,
Count:=oFldIndexEntry.Code.Characters.Count + 2
End If
End If
Wend
End With
rngStory.Expand unit:=wdStory
Next i
'Show field codes for TOC to prevent looping
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = False
End If
Next oFld

End Sub

 

[Greg Maxey]

Chuck,

I think I found the cause of your circular loops

We were using
ActiveWindow.View.ShowHiddenText = False
to hide the XE fields as they where generated. I just discovered that that
command will not ensure hidden text is toggled off.

To ensure the hidden text is off in the document being processed use:

ActiveDocument.ActiveWindow.View.ShowHiddenText = False

Or better yet Tools>Options>View and make sure it is off.

With hidden text off, the indexer will not try to index the XE Index fields
and therefore I don't think we need to collapse the range until after the
fields. In fact if the fields aren't showing (which they shouldn't be) then
the range would skip over portions of text. I think that is why I was
seeing erratic behaviour with your code earlier.

Ponder this a bit and let me know what you think.

I alse believe we can move our Toggle TOC and Index field code snippets into
the main macro. Toggle them to show once and then back off. We can then
combine the TOC toggle and clear bold in one bit.

Here is a freshly amended draft:

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 oFld As Field

ActiveDocument.ActiveWindow.View.ShowHiddenText = False
'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
StripPreviousIndexing
'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
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 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
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, "|")
'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
RestoreSmartQuotes
End If
'Main routine
Application.ScreenUpdating = False
'Show field codes for TOC and any INDEX field to prevent indexing
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = True
End If
Next oFld
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
SearchAndReplaceInStoryA rngStory, ListArray 'My Version
'SearchAndReplaceInStoryB rngStory, ListArray 'Chuck's Version
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
'Toggle field codes and clear bold in TOC fields
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 TOC fields/8 Index fields
oFld.ShowCodes = False
End If
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
End If
Next oFld
RestoreTextColor
Application.ScreenUpdating = True
ActiveDocument.ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey unit:=wdStory
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

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 = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim 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
'See the result
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
Sub StripPreviousIndexing()
Dim oFld As Field
Dim rngStory As Range

MakeHFValid
For Each rngStory In ActiveDocument.StoryRanges
Do Until (rngStory Is Nothing)
For Each oFld In rngStory.Fields
If oFld.Type = 4 Then
'If oFld.Type = wdFieldIndex Or oFld.Type = wdFieldIndexEntry Then
'Index entry
oFld.Delete
End If
Next oFld
Set rngStory = rngStory.NextStoryRange
Loop
Next
End Sub
Sub RestoreSmartQuotes()
'Restores smart quotes then replaces smart quotes appearing in fields with
'straight quotes
Dim rngStory As Word.Range
Dim oFld As Field
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 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 Sub
Public Sub SearchAndReplaceInStoryA(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 = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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 SearchAndReplaceInStoryB( _
ByVal rngStory As Word.Range, _
ByRef ListArray As Variant)
Dim i As Long
Dim oFldIndexEntry As Field
For i = LBound(ListArray) To UBound(ListArray)
Selection.HomeKey unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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
If rngStory.StoryType < 4 Then
Set oFldIndexEntry =
ActiveDocument.Indexes.MarkEntry(Range:=rngStory, _
Entry:=Trim(ListArray(i)))
oFldIndexEntry.Code.Text = oFldIndexEntry.Code.Text & "\f
""DefinedTermsIndex"" "
rngStory.MoveEnd unit:=wdCharacter,
Count:=oFldIndexEntry.Code.Characters.Count + 2
End If
End If
Wend
End With
rngStory.Expand unit:=wdStory
Next i
End Sub

 

[Greg Maxey]

Chuck,

The visible hidden text seems to have been the root of several evils in our
earlier code. After further testing, I see no reason for strippring
pre-existing XE fields. I also don't see a reason for the special restore
smart quote routine. I have cleaned things up a bit here and ask that you
or anyone else interested treat it as a base line.

If I am wrong about any of my assumptions I am certainly willing to have
another look.

Here it is:
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 oFld As Field

ActiveDocument.ActiveWindow.View.ShowHiddenText = False
'Stores users AutoCorrect "smart quote" options. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes
'Convert smart quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False
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 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
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, "|")
'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 smart qoutes per user option
If enableSmartQuotes Then
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
End If
'Main routine
Application.ScreenUpdating = False
'Show field codes for and existing TOCs and INDEXs prevent indexing
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 is TOC fields/8 is Index
fields
oFld.ShowCodes = True
End If
Next oFld
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
'Toggle field codes and clear bold in TOC fields
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 is TOC fields/8 is Index
fields
oFld.ShowCodes = False
End If
If oFld.Type = wdFieldTOC Then
oFld.Result.Font.Bold = False
End If
Next oFld
RestoreTextColor
Application.ScreenUpdating = True
ActiveDocument.ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey unit:=wdStory
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

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 = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Function ListSort(ListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim 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
'See the result
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
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 = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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
If rngStory.StoryType < 4 Then
ActiveDocument.Indexes.MarkEntry Range:=rngStory,
Entry:=Trim(ListArray(i))
End If
End If
Wend
End With
rngStory.Expand unit:=wdStory
Next i
End Sub

 

[Greg Maxey]

To all still interested:

I have been polishing the cannonball and I think all of the bugs are worked
out expect the issue with marking and indexing terms in bookmarks. I think
I know how to fix that and I have a querry out in another thread or string
whatever they are called. In the meantime bkmDefined Termbkm must be
bkmDefined Term bkm (or a trailing space to prevent waxing the bookmark when
the text marking takes place.

Here is the latest. I have added a Function to prevent duplicate terms from
appearing in the array and some other refinements:
Option Explicit
Private rngStory As Word.Range
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich
Dim enableSmartQuotes As Boolean
Dim listArray
Dim pTag As String
Dim myRange As Range

Dim oFld As Field
Dim bIndexExist As Boolean

'Set display of hidden text off
ActiveDocument.ActiveWindow.View.ShowHiddenText = False

'Store user's current AutoCorrect "smart quote" option. True if enabled
enableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

'Set/confirm straight quotes are applied (search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle

'Build Defined Terms list and create array
listArray = BuildArray(listArray)

'Reports and options
Application.ScreenUpdating = True
'Exit macro if no Defined Terms are found
If listArray(0) = "" Then
MsgBox "There are no 'Defined Terms' annotated in this document." _
& vbCr & " 'Defined Terms' must be in bold text and enclosed " _
& "in quotes.", vbExclamation
End
'Polish the cannon ball
ElseIf listArray(0) <> "" And UBound(listArray) = 0 Then
pTag = ""
Else: pTag = "s"
End If

If MsgBox("Document contains " & UBound(listArray) + 1 _
& " Defined Term" & pTag & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbYes Then
Application.ScreenRefresh
Application.ScreenUpdating = False
'Validate blank headers and footers (ensure code sequences to next HF
storyrange
MakeHFValid
'Restore qoutes per user option
If enableSmartQuotes Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
SmartQuoteToggle
End If

'Main routine
Application.ScreenUpdating = False
'Show field codes for any existing TOCs and INDEXs to prevent
'these text areas
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then
'13 is a TOC fields/8 is a Index field
oFld.ShowCodes = True
End If
Next oFld
'Cycle through each rangestory and mark/index terms
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then 'skips very short storyranges
SearchAndReplaceInStory listArray
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
'Toggle TOC and INDEX field codes and clear bold in TOC fields
bIndexExist = False 'set default
For Each oFld In ActiveDocument.Fields
If oFld.Type = 13 Or oFld.Type = 8 Then '13 is TOC fields/8 is Index
fields
oFld.ShowCodes = False
End If
'Identify an existing INDEX field for update options
If oFld.Type = 8 Then bIndexExist = True
If oFld.Type = wdFieldTOC Then oFld.Result.Font.Bold = False
Next oFld
RestoreTextColor
If Not bIndexExist Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set myRange = ActiveDocument.Range
myRange.Move
myRange.InsertBreak wdSectionBreakNextPage
myRange.Move
myRange.Text = "INDEX OF DEFINED TERMS" & vbCr
myRange.Bookmarks.Add Name:="Index", Range:=myRange
myRange.Move
myRange.Fields.Add myRange, wdFieldEmpty, "INDEX \e """ & vbTab & """
\c ""1"" \z ""1033""", False
Selection.EndKey wdStory
End If
ElseIf MsgBox("Do you want to update the existing index?", vbYesNo +
vbQuestion) = vbYes Then
Set myRange = ActiveDocument.Range
myRange.Fields.Update
Selection.GoTo What:=wdGoToBookmark, Name:="Index"
End If
Application.ScreenUpdating = True
MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"
End If
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub SmartQuoteToggle()
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Function BuildArray(listArray) As Variant
Dim myRange As Range
Dim tempList() As String
Dim pDefinedTerm As String
Dim counter As Long

Set myRange = ActiveDocument.Range
ReDim tempList(0)
Do
With myRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
'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
Select Case myRange.Text
Case Is <> ""
myRange.Text = Trim(myRange.Text)
pDefinedTerm = myRange.Text
'Check pDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If pDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = pDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
myRange.End = myRange.End + 1
myRange.Collapse wdCollapseEnd
End With
Loop While myRange.Find.Found
'Remove last, empty entry if anything was added
If UBound(tempList) > 0 Then ReDim Preserve tempList(UBound(tempList) - 1)
'Define the array
listArray = tempList
'Call sort function to sort array longest term to shortest term
BuildArray = ListSort(listArray)
End Function
Function ListSort(listArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim 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
End Function
Public Sub SearchAndReplaceInStory(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 = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.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
'Index in valid storyRanges only (maintext, footnotes, endnotes)
If rngStory.StoryType < 4 Then
ActiveDocument.Indexes.MarkEntry Range:=rngStory,
Entry:=Trim(listArray(i))
End If
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i
End Sub
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

 

[Helmut Weber]

Hi Chuck,

I didn't follow all of this thread, but it seems,
once you have a list of terms and term x is found,
one would have to look whether this term x is included
in a longer term, right where it is. Therefore
create a range for term x, and check, whether any
other longer term's range, when searched for and found,
includes the range x. Awful, but logical, IMHO.

So for indexing, once you have a list of terms,
sort them according to their length, and index them
form the longest to the shortest.

Remains the question of word forms, and of somehow
combined terms, and of terms with possibly reversed word order.

Everything concerning natural language is fuzzy.
It's no mathematics.

Greetings from Bavaria, Germany

Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
http://word.mvps.org/

 

[Chuck]

Hi Greg

You've done a lot of work and it's great. I've gone through and made a
number of changes...

Following on from a previous post, and given that GG has not said otherwise,
this code is posted under the terms of the GPL. Please see
http://www.gnu.org/licenses/gpl.txt for terms and a link to background
information about the GPL here http://www.gnu.org/copyleft/.

You mention " bkmDefined Termbkm" but I can't find that anywhere in the code.

It’s necessary to name index entries "DefinedTermsIndex" so that they can be
identified and removed at will – there may be more than one index in a
document. I've amended the Index field creation code accordingly. Note that
I've added code to test whether the index field bookmark exists because users
may delete an existing index before re-indexing, which would delete the
bookmark and cause an error. I've also simplified the Index field switches
to just the essentials.

If a user wants to index defined terms more than once, the indexer needs to
eliminate existing index entry fields because users can conceivably delete
instances of defined terms without deleting the index entry fields (I’ve
tested that scenario) so you can end up with orphaned index entry fields that
need to be deleted before re-indexing. I noticed that when I ran the

I’ve kept the strip index entry macro as a separate macro because that way
it can be used as a standalone utility – for instance, the strip index entry
macro can be run from a toolbar without re-indexing. When finalising a
document, users won’t want the index or the entries to appear in the document.

When searching for defined terms, match case needs to be set to true because
there's a difference between "Consultant" and "consultant" (the first is a
defined term, the second is not, and both may be used in the same document
(and the same sentence)).

The code that tests which story range is being processed is in the main sub
(no need to run SearchAndReplaceInStory if the story range isn't appropriate).

I've cleaned up variable names so that they're consistent and prefixed with
variable type (rngRange instead of myRange for example). I've also cleaned
up the If-EndIf structures (sometimes they were one line, sometimes
multi-line).

In the main sub, if a user answers No to either of the message boxes (no
defined terms found / x found do you want to continue), the macro simply
exits. That way, the majority of code doesn't run within an If test and it's
easier to correlate IFs with END IFs.

I've created a RestoreUserOptionsAndEnd sub that is can be called at 3
points in the main sub, whenever the sub exits. Any other cleanup code can
be put there rather than inserting it at various points elsewhere.

Please use this code as a new base line...

Option Explicit

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

Dim rngStory As Word.Range
Dim arrListArray
Dim strPlural As String
Dim rngRange As Range
Dim blnHideHiddenText As Boolean
Dim blnIndexExist As Boolean
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field

StripPreviousIndexing

'Store user's AutoCorrect "smart quote"
'and hidden text view options. True if enabled
blnEnableSmartQuotes = _
Options.AutoFormatAsYouTypeReplaceQuotes
blnHideHiddenText = _
ActiveDocument.ActiveWindow.View.ShowHiddenText

'Hide index field text while processing
ActiveDocument.ActiveWindow.View.ShowHiddenText = False

'Set/confirm straight quotes are applied
'(search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle

'Build Defined Terms list and create array
arrListArray = BuildArray(arrListArray)

SmartQuoteToggle

'Reports and options

'Exit macro if no Defined Terms are found
'else determine if reference to "defined term"
'should be plural
If arrListArray(0) = "" Then
MsgBox "There are no defined terms in this document." _
& vbCr & _
" Defined terms must be in bold text and enclosed " _
& "in double (not single) quotes.", vbExclamation
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
Exit Sub
ElseIf arrListArray(0) <> "" And UBound(arrListArray) = 0 Then
strPlural = ""
Else
strPlural = "s"
End If

If MsgBox("Document contains " & UBound(arrListArray) + 1 _
& " defined term" & strPlural & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbNo Then
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox "Index entries have been removed from " & _
"this document.", _
vbOKOnly + vbExclamation, _
"Index entries not marked"
Exit Sub
End If

Application.ScreenRefresh
Application.ScreenUpdating = False

'Validate blank headers and footers
MakeHFValid

'Main routine
Application.ScreenUpdating = False

'Show field codes for any existing TOCs
'and INDEXs to prevent these text areas
'from being indexed
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is a TOC fields/8 is a Index field
fldField.ShowCodes = True
End If
Next fldField

'Cycle through each story range and mark/index terms
'Process only main, footnote and endnote stories
For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
SearchAndReplaceInStory _
rngStory, _
arrListArray
End If
Set rngStory = rngStory.NextStoryRange
End If
Next

'Toggle TOC and INDEX field codes
'and clear bold in TOC fields
blnIndexExist = False 'set default

For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is TOC fields/8 is Index Fields
fldField.ShowCodes = False
End If
'Identify an existing DefinedTermsIndex
'INDEX field for update options
If fldField.Type = 8 And _
InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
blnIndexExist = True
End If
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
End If
Next fldField

RestoreTextColor

If blnIndexExist = False Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
With rngRange
.Move
.InsertBreak wdSectionBreakNextPage
.Move
.Text = "INDEX OF DEFINED TERMS" & vbCr
.Bookmarks.Add _
Name:="DefinedTermsIndex", _
Range:=rngRange
.Move
.Fields.Add _
rngRange, _
wdFieldEmpty, _
"INDEX \f ""DefinedTermsIndex""", _
False
End With
'Selection.EndKey wdStory
End If
Else
If MsgBox("Do you want to update the existing index?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
rngRange.Fields.Update
If ActiveDocument.Bookmarks.Exists("DefinedTermsIndex") Then
Selection.GoTo What:=wdGoToBookmark, _
Name:="DefinedTermsIndex"
End If
End If
End If

RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText

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

End Sub
Public Sub MakeHFValid()

Dim lngJunk As Long

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

End Sub
Sub SmartQuoteToggle()

Dim rngStory

For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
'Restore straight quotes in fields
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory

End Sub

Function BuildArray(arrListArray) As Variant

Dim rngRange As Range
Dim tempList() As String
Dim strDefinedTerm As String
Dim counter As Long

Set rngRange = ActiveDocument.Range
ReDim tempList(0)

Do
With rngRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
'Strip quotation marks
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)
strDefinedTerm = rngRange.Text
'Check strDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If strDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = strDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found
'Remove last, empty entry if anything was added

If UBound(tempList) > 0 Then
ReDim Preserve tempList(UBound(tempList) - 1)
End If

'Define the array
arrListArray = tempList

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

End Function
Function ListSort(arrListArray) As Variant

'Modified from code found in Google Groups

Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String

first = LBound(arrListArray)
last = UBound(arrListArray)
ReDim sortedList(last)

For i = first To last
For j = i + 1 To last
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
temp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = temp
End If
Next j
Next i

For i = first To last
sortedList(i) = arrListArray(i)
Next i

ListSort = sortedList

End Function

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

Dim i As Long
Dim fldIndexEntry As Field

For i = LBound(arrListArray) To UBound(arrListArray)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrListArray(i)
While .Execute
With rngStory
.Text = .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrListArray(i)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i

End Sub

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 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 InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
fldField.Delete
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
Next

End Sub

Sub RestoreUserOptionsAndEnd( _
ByVal blnEnableSmartQuotes As Boolean, _
ByVal blnHideHiddenText As Boolean)

Options.AutoFormatAsYouTypeReplaceQuotes = _
blnEnableSmartQuotes
ActiveDocument.ActiveWindow.View.ShowHiddenText = _
blnHideHiddenText

Application.ScreenUpdating = True

End Sub

 

[Greg]

Chuck,

Good work. It appears that there is some disagreement on what should
or shouldn't be indexed etc. or how. Since I have little use for the
indexer other than a learning tool I am not taking sides. I have a
this full blown version and one a little stripped down.

To your particular comments:

1. Terms found but not used are an oversight. As you or I continue to
polish the cannon ball we will likely see more. One example it
MakeHFValid. As we are no longer indexing in the header or footer this
code is redundant.

2. Again the "DefinedTermsIndex" is a choice. It appears to work well

3. I added the rangestorytype test to the index stripper and pull the
MakeHFValid code

4. Regarding match case. The OP, who started this whole thing,
specified that if "Consultant" was bold and quoted in the defined terms
section then any instance of consultant found in the text should be
BOLDed first capped and indexed> I wouldn't know.

5. Roger the story range test. However I have make
SearchAndReplaceInStory a Function to facilitate counters.

6. Concur with all other comments. I am attaching your code marked up
with some commented text.

Standing by for your thoughts.

Option Explicit
Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, Chuck Henrich and G.G. Yagoda
Dim rngStory As Word.Range
Dim arrListArray
Dim strPlural As String
Dim numTerms As Long 'Added
Dim rngRange As Range
Dim blnHideHiddenText As Boolean
Dim blnIndexExist As Boolean
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field

StripPreviousIndexing
'Store user's AutoCorrect "smart quote"
'and hidden text view options. True if enabled
blnEnableSmartQuotes = _
Options.AutoFormatAsYouTypeReplaceQuotes
blnHideHiddenText = _
ActiveDocument.ActiveWindow.View.ShowHiddenText
'Hide index field text while processing
ActiveDocument.ActiveWindow.View.ShowHiddenText = False
'Set/confirm straight quotes are applied
'(search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle
'Build Defined Terms list and create array
arrListArray = BuildArray(arrListArray)
SmartQuoteToggle
'Reports and options
'Exit macro if no Defined Terms are found
'else determine if reference to "defined term"
'should be plural
If arrListArray(0) = "" Then
MsgBox "There are no defined terms in this document." _
& vbCr & _
" Defined terms must be in bold text and enclosed " _
& "in double (not single) quotes.", vbExclamation
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
Exit Sub
ElseIf arrListArray(0) <> "" And UBound(arrListArray) = 0 Then
strPlural = ""
Else
strPlural = "s"
End If
numTerms = UBound(arrListArray) + 1
If MsgBox("Document contains " & numTerms & "" _
& " defined term" & strPlural & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbNo Then
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox "Index entries have been removed from " & _
"this document.", _
vbOKOnly + vbExclamation, _
"Index entries not marked"
Exit Sub
End If
Application.ScreenRefresh
Application.ScreenUpdating = False
'Validate blank headers and footers
'MakeHFValid We don't need it as headers and footers aren't indexed
'Main routine
Application.ScreenUpdating = False
'Show field codes for any existing TOCs
'and INDEXs to prevent these text areas
'from being indexed
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is a TOC fields/8 is a Index field
fldField.ShowCodes = True
End If
Next fldField
'Cycle through each story range and mark/index terms
'Process only main, footnote and endnote stories
Dim l As Long
Dim k As Long
Dim m As Long
For Each rngStory In ActiveDocument.StoryRanges
l = 0
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
k = 0
l = l + SearchAndReplaceInStory( _
rngStory, _
arrListArray, k)
End If
Set rngStory = rngStory.NextStoryRange
End If
m = m + l
Next
'Toggle TOC and INDEX field codes
'and clear bold in TOC fields
blnIndexExist = False 'set default
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is TOC fields/8 is Index Fields
fldField.ShowCodes = False
End If
'Identify an existing DefinedTermsIndex
'INDEX field for update options
If fldField.Type = 8 And _
InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
blnIndexExist = True
End If
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
End If
Next fldField
RestoreTextColor
If blnIndexExist = False Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
With rngRange
.Move
.InsertBreak wdSectionBreakNextPage
.Move
.Text = "INDEX OF DEFINED TERMS" & vbCr
.Bookmarks.Add _
Name:="DefinedTermsIndex", _
Range:=rngRange
.Move
.Fields.Add _
rngRange, _
wdFieldEmpty, _
"INDEX \f ""DefinedTermsIndex""", _
False
End With
'Selection.EndKey wdStory
End If
Else
If MsgBox("Do you want to update the existing index?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
rngRange.Fields.Update
If ActiveDocument.Bookmarks.Exists("DefinedTermsIndex")
Then
Selection.GoTo What:=wdGoToBookmark, _
Name:="DefinedTermsIndex"
End If
End If
End If
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox numTerms & " Defined Term" & strPlural & " has been marked or
indexed " _
& m & " times in this document.", vbOKOnly, "Done"
End Sub
'Headers and Footers are not indexed anymore so we don't need this bit
'Public Sub MakeHFValid()
'Dim lngJunk As Long
'lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'End Sub
Sub SmartQuoteToggle()
Dim rngStory
For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory
End Sub
Function BuildArray(arrListArray) As Variant
Dim rngRange As Range
Dim tempList() As String
Dim strDefinedTerm As String
Dim counter As Long
Set rngRange = ActiveDocument.Range
ReDim tempList(0)
Do
With rngRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.Text = """*"""
.MatchWildcards = True
.Execute
'Strip quotation marks
rngRange.Start = rngRange.Start + 1
rngRange.End = rngRange.End - 1
'Confirm range start and end is bold text
If rngRange.Characters.first.Font.Bold = True _
And rngRange.Characters.last.Font.Bold = True Then
'Elimate zero length strings and erroneous white space
Select Case rngRange.Text
Case Is <> ""
rngRange.Text = Trim(rngRange.Text)
strDefinedTerm = rngRange.Text
'Check strDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If strDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = strDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found
'Remove last, empty entry if anything was added
If UBound(tempList) > 0 Then
ReDim Preserve tempList(UBound(tempList) - 1)
End If
'Define the array
arrListArray = tempList
'Call sort function to sort array longest term to shortest term
BuildArray = ListSort(arrListArray)
End Function
Function ListSort(arrListArray) As Variant
'Modified from code found in Google Groups
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
Dim temp As Variant
Dim sortedList As Variant
Dim myString As String
first = LBound(arrListArray)
last = UBound(arrListArray)
ReDim sortedList(last)
For i = first To last
For j = i + 1 To last
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
temp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = temp
End If
Next j
Next i
For i = first To last
sortedList(i) = arrListArray(i)
Next i
ListSort = sortedList
End Function
Public Function SearchAndReplaceInStory( _
ByVal rngStory As Word.Range, _
ByRef arrListArray As Variant, k As Long)
Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim bkmName As String 'Added to handled bookmarked ranges
Dim fldIndexEntry As Field
For i = LBound(arrListArray) To UBound(arrListArray)
Selection.HomeKey Unit:=wdStory
j = 0
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrListArray(i)
While .Execute
With rngStory
'Special thanks to Helmut Weber for steering us through
'dealing with bookmarked ranges
If .Bookmarks.Count = 1 Then
bkmName = .Bookmarks(1).Name
.Text = arrListArray(1) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Bookmarks.Add Name:=bkmName
End If
If .Bookmarks.Count = 0 Then
.Text = arrListArray(1) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
End If
.Collapse Direction:=wdCollapseEnd
End With
j = j + 1
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrListArray(i)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
k = k + j
Next i
SearchAndReplaceInStory = k
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 StripPreviousIndexing()
Dim fldField As Field
Dim rngStory As Range
'MakeHFValid
For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then 'Bypass ranges not indexed
Do Until (rngStory Is Nothing)
For Each fldField In rngStory.Fields
If rngStory.StoryType < 4 Then
If fldField.Type = 4 Then 'Index entry
If InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
fldField.Delete
End If
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
End If
Next
End Sub
Sub RestoreUserOptionsAndEnd( _
ByVal blnEnableSmartQuotes As Boolean, _
ByVal blnHideHiddenText As Boolean)
Options.AutoFormatAsYouTypeReplaceQuotes = _
blnEnableSmartQuotes
ActiveDocument.ActiveWindow.View.ShowHiddenText = _
blnHideHiddenText
Application.ScreenUpdating = True
End Sub

 

[Greg]

Chuck,

In the code I just sent there is a typo in the SearchAndReplaceInStory
function.

Change arrListArray(1) to arrListArray(i) in two places.

 

[Chuck]

Thanks for the feedback. Before I look at your new code, something I've
noticed. When you post code, there's rarely blank lines within the code. I
find that really hard to read -- do you have code that retains the blank
lines I posted? It's not strictly a functional issue but with this amount of
code blank lines are way easier on the eye... TIA

 

[Chuck]

PS - regarding match case. If the user is looking for instances of the
defined term, then match case is required because "Consultant" is an instance
of a defined term but "consultant" isn't. However if the user is looking for
all instances of a defined term, whether used as a defined term or not,
that's a different story.

At the end of the day, not all scenarios can be catered for in the base
code, some bells and whistles have to be dealt with through user form choices
etc. I'm assuming that we're dealing with basic functionality and for users
in legal contexts defined terms require match case.

 

[Greg]

Chuck,

I cut and pasted your code directly into my VBE editor and then back in
here. The blanks must be stripped in route, because there were only a
few blank lines in the code I pasted into my editor.

Sorry.

 

[Chuck]

Hi Greg

Thanks for the code, it works good. Don’t understand the blank line
stripping thing – doesn’t happen with other code but it’s not a huge issue.

Can I assume that the GPL is okay with you? Essentially the GPL allows
anyone to freely use the code but with restrictions. Below is a brief
overview of the concept of the GPL, links to the exact terms FAQ etc were in
previous posts of mine:

"When we speak of free software, we are referring to freedom, not price. Our
General Public Licenses are designed to make sure that you have the freedom
to distribute copies of free software (and charge for this service if you
wish), that you receive source code or can get it if you want it, that you
can change the software or use pieces of it in new free programs; and that
you know you can do these things.
***
For example, if you distribute copies of such a program, whether gratis or
for a fee, you must give the recipients all the rights that you have. You
must make sure that they, too, receive or can get the source code. And you
must show them these terms so they know their rights."

Since this code is already de facto freely available (anyone can access it
in a public newsgroup), the GPL makes sense to me as a way to protect the
code from being unfairly "privatised" by some third party, allowing people to
collaborate on it, improve it, adapt it to their own purposes, etc.

On to the code:

Regarding the bookmarking issue: I’m not sure that’s desirable. It’s not
necessary to replace the rngStory.Text in the code below (from
SearchAndReplaceInStory) because we’re applying attributes to a found
instance not doing a global find and replace. Further, if a defined term
appears within a bookmark the bookmark may cover more text than just the
defined term and redefining the bookmark to the defined term would not be
helpful.

I remmed out the bkmName and .Text lines in the code below and the indexing
works fine:

While .Execute
With rngStory
'Special thanks to Helmut Weber for steering us through
'dealing with bookmarked ranges
'If .Bookmarks.Count = 1 Then
'bkmName = .Bookmarks(1).Name
'.Text = arrListArray(1) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
'.Bookmarks.Add Name:=bkmName
‘End If
‘If .Bookmarks.Count = 0 Then
'.Text = arrListArray(1) 'vice .Text
‘.Font.Bold = True
‘.Font.Color = wdColorBlueGray
‘End If

I don’t understand what the variables k, l, m are designed to do. I also
don’t think they’re necessary since the indexing was working without them.
Could you explain them and/or give them more self-explanatory names? If
they're counters to keep track of how many times defined terms occur, they
might not be necessary because using an array to count the number of
instances would be more flexible (see below).

Re determining whether any terms are defined but not used: if a defined
term appears only once, then it is defined but not used (the definition being
the only time it appears). I've added code in WordMarkerWithIndexer that
creates a new array (arrCounterArray) that has 2 dimensions, 1st dimension is
defined term, 2nd is number of times that term is found) – I didn't make that
change in BuildArray because that function uses ListSort and I thought it was
simpler to let ListSort deal with a single dimension array. What do you
think?

SearchAndReplaceInStory now passes arrCounterArray instead of arrListArray
so that when each story range is processed the counter for each term is
passed along with it. Appropriate changes have been made to
SearchAndReplaceInStory to reflect the use of arrCounterArray and 2
dimensions.

At the end of WordMarkerWithIndexer I show how you can use arrCounterArray
to count the total number of instances as well as the number of terms defined
but not used.

In SearchAndReplaceInStory I changed MatchWholeWord to False to pick up
plurals and possessives.

I've added code to StripPreviousIndexing to de-bold indexed terms. The code
needs to pick up the defined terms from the Field.Code.Text because there may
be "orphaned" defined terms – definitions may have been deleted from the
document without deleting all indexed instances.

Looking forward to your comments...

Option Explicit

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

Dim rngStory As Word.Range
Dim arrListArray
Dim arrCounterArray
Dim strPlural As String
Dim numTerms As Long
Dim i As Long
Dim lngInstances As Long
Dim rngRange As Range
Dim blnHideHiddenText As Boolean
Dim blnIndexExist As Boolean
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field

StripPreviousIndexing

'Store user's AutoCorrect "smart quote"
'and hidden text view options. True if enabled
blnEnableSmartQuotes = _
Options.AutoFormatAsYouTypeReplaceQuotes
blnHideHiddenText = _
ActiveDocument.ActiveWindow.View.ShowHiddenText

'Hide index field text while processing
ActiveDocument.ActiveWindow.View.ShowHiddenText = False

'Set/confirm straight quotes are applied
'(search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle

'Build Defined Terms list and create array
arrListArray = BuildArray(arrListArray)

SmartQuoteToggle

'Reports and options

'Exit macro if no Defined Terms are found
'else determine if reference to "defined term"
'should be plural
If arrListArray(0) = "" Then
MsgBox "There are no defined terms in this document." _
& vbCr & _
" Defined terms must be in bold text and enclosed " _
& "in double (not single) quotes.", vbExclamation
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
Exit Sub
ElseIf arrListArray(0) <> "" And UBound(arrListArray) = 0 Then
strPlural = ""
Else
strPlural = "s"
End If

numTerms = UBound(arrListArray) + 1

If MsgBox("Document contains " & numTerms & "" _
& " defined term" & strPlural & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbNo Then
RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox "Index entries have been removed from " & _
"this document.", _
vbOKOnly + vbExclamation, _
"Index entries not marked"
Exit Sub
End If

Application.ScreenRefresh
Application.ScreenUpdating = False

'Main routine

Application.ScreenUpdating = False

'Show field codes for any existing TOCs
'and INDEXs to prevent these text areas
'from being indexed
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is a TOC fields/8 is a Index field
fldField.ShowCodes = True
End If
Next fldField

'Create new counter array
'1st dimension = defined term
'2nd dimension = number of times found
ReDim arrCounterArray(UBound(arrListArray), 1)
For i = 0 To UBound(arrListArray)
arrCounterArray(i, 0) = arrListArray(i)
Next

'Cycle through each story range and mark/index terms
'Process only main, footnote and endnote stories
For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
arrCounterArray = SearchAndReplaceInStory( _
rngStory, _
arrCounterArray)
End If
Set rngStory = rngStory.NextStoryRange
End If
Next

'Toggle TOC and INDEX field codes
'and clear bold in TOC fields
blnIndexExist = False 'set default
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is TOC fields/8 is Index Fields
fldField.ShowCodes = False
End If
'Identify an existing DefinedTermsIndex
'INDEX field for update options
If fldField.Type = 8 And _
InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
blnIndexExist = True
End If
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
End If
Next fldField

RestoreTextColor

If blnIndexExist = False Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
With rngRange
.Move
.InsertBreak wdSectionBreakNextPage
.Move
.Text = "INDEX OF DEFINED TERMS" & vbCr
.Bookmarks.Add _
Name:="DefinedTermsIndex", _
Range:=rngRange
.Move
.Fields.Add _
rngRange, _
wdFieldEmpty, _
"INDEX \f ""DefinedTermsIndex""", _
False
End With
'Selection.EndKey wdStory
End If
Else
If MsgBox("Do you want to update the existing index?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
rngRange.Fields.Update
If ActiveDocument.Bookmarks.Exists("DefinedTermsIndex") Then
Selection.GoTo What:=wdGoToBookmark, _
Name:="DefinedTermsIndex"
End If
End If
End If

RestoreUserOptionsAndEnd _
blnEnableSmartQuotes, _
blnHideHiddenText

'Count how many instances of defined terms
'by adding 2nd dimension of arrCounterArray
lngInstances = 0
For i = 0 To UBound(arrCounterArray)
lngInstances = lngInstances + arrCounterArray(i, 1)
Next i

MsgBox numTerms & " defined term" & strPlural & " marked or indexed " _
& lngInstances & " times in this document.", vbOKOnly, "Done"

'Count how many defined terms defined but
'not used (used only once)
lngInstances = 0
For i = 0 To UBound(arrCounterArray)
If arrCounterArray(i, 1) = 1 Then
lngInstances = lngInstances + 1
End If
Next i

If lngInstances > 1 Then
strPlural = "s were"
Else
strPlural = " was"
End If

If lngInstances > 0 Then
MsgBox lngInstances & " term" & strPlural & " defined but not used.",
vbOKOnly
End If

End Sub

Sub SmartQuoteToggle()

Dim rngStory

For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.ClearFormatting
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory

End Sub

Function BuildArray(arrListArray) As Variant

Dim rngRange As Range
Dim tempList() As String
Dim strDefinedTerm As String
Dim counter As Long
Set rngRange = ActiveDocument.Range

ReDim tempList(0)

Do
With rngRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.ClearFormatting
.Text = """*"""
.MatchWildcards = True
.Execute
'Strip quotation marks
rngRange.Start = rngRange.Start + 1
rngRange.End = rngRange.End - 1
'Confirm range start and end is bold text
If rngRange.Characters.first.Font.Bold = True _
And rngRange.Characters.last.Font.Bold = True Then
'Elimate zero length strings and erroneous white space
Select Case rngRange.Text
Case Is <> ""
rngRange.Text = Trim(rngRange.Text)
strDefinedTerm = rngRange.Text
'Check strDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If strDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = strDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found

'Remove last, empty entry if anything was added
If UBound(tempList) > 0 Then
ReDim Preserve tempList(UBound(tempList) - 1)
End If

'Define the array
arrListArray = tempList

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

End Function

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

Dim i As Long
Dim j As Long
Dim first As Long
Dim last As Long
Dim temp As Variant
Dim arrSortedList As Variant
Dim strString As String

first = LBound(arrListArray)
last = UBound(arrListArray)

ReDim arrSortedList(last)

For i = first To last
For j = i + 1 To last
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
temp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = temp
End If
Next j
Next i

For i = first To last
arrSortedList(i) = arrListArray(i)
Next i

ListSort = arrSortedList

End Function

Public Function SearchAndReplaceInStory( _
ByVal rngStory As Word.Range, _
ByRef arrCounterArray As Variant)

Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim fldIndexEntry As Field

For i = 0 To UBound(arrCounterArray, 1)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrCounterArray(i, 0)
While .Execute
With rngStory
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
arrCounterArray(i, 1) = arrCounterArray(i, 1) + 1
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrCounterArray(i, 0)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i

SearchAndReplaceInStory = arrCounterArray

End Function

Sub RestoreTextColor()

Dim rngStory As Word.Range

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 StripPreviousIndexing()

Dim fldField As Field
Dim rngStory As Range
Dim rngRange As Range
Dim strString As String
Dim arrTemp

For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then 'Bypass ranges not indexed
Do Until (rngStory Is Nothing)
For Each fldField In rngStory.Fields
If rngStory.StoryType < 4 Then
If fldField.Type = 4 Then 'Index entry
If InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then

fldField.Select
ActiveDocument.Bookmarks.Add _
"XEfield", Selection.Range

Set rngRange = _
ActiveDocument.Bookmarks("XEfield").Range
rngRange.Select

strString = fldField.Code.Text
strString = Replace(strString, Chr(34), "|")
arrTemp = Split(strString, "|")
strString = arrTemp(1)

With rngRange
.Collapse wdCollapseStart
'Ignore if definition (enclosed in quotes)
.MoveStart _
wdCharacter, 0 - (Len(strString) + 1)
If rngRange.Characters.first <> Chr(34) Then
.MoveStart wdCharacter, 1
If .Font.Bold = True Then
.Font.Bold = False
.Select
End If
End If
End With

fldField.Delete
Erase arrTemp
End If
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
End If
Next

If ActiveDocument.Bookmarks.Exists("XEfield") Then
ActiveDocument.Bookmarks("XEfield").Delete
End If

End Sub

Sub RestoreUserOptionsAndEnd( _
ByVal blnEnableSmartQuotes As Boolean, _
ByVal blnHideHiddenText As Boolean)

Options.AutoFormatAsYouTypeReplaceQuotes = _
blnEnableSmartQuotes
ActiveDocument.ActiveWindow.View.ShowHiddenText = _
blnHideHiddenText
Application.ScreenUpdating = True

End Sub

 

[Greg Maxey]

Chuck,

I posted a rather lenghty reply from the Google Groups interface, but it
appears lost in the ether.

A condesed version:

GPL is fine with me.

k,l,m was for counting as you suspected. I like your method much better.
Before starting on this project two weeks ago I knew very little about
arrays or passing arguments. I have learned alot through developing this
code the whole concept is still a little foggy. That said, you will
understand that I can't really offer an intelligent opinion on if that
method should be expanded to the ListSort arrays.

I like everything that you have done except for removing the bookmark
handling routine in the SearchAndReplaceInStory function. Partly because I
spent so much time trying to figure it out ;-) and partly because the OP
which I started this for specifically required that each "BOLD" quoted entry
was a defined term and each that occurance of the term be processed. So
"Consultant" in bold would make every occurrance of consultant Consultant in
bold.

I agree that with the method used now that there is no need for the bookmark
routine. However with a few lines of code we can provide the option to use
..MatchCase True or False. If False is selected then we can replace found
text with the argument term. To do this we must then deal with the defined
term that is "tight" in a bookmark. I hadn't thought through the defined
term within a broader bookmark and I see the problems that would cause. I
think that I have that worked out. I am only posting back the
SearchAndReplaceInStory bit. Plug it in the existing code and let me know
what you think


Public Function SearchAndReplaceInStory( _
ByVal rngStory As Word.Range, _
ByRef arrCounterArray As Variant)


Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim fldIndexEntry As Field
Dim bkmName As String

For i = 0 To UBound(arrCounterArray, 1)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrCounterArray(i, 0)
While .Execute
If .MatchCase = True Then
With rngStory
.Font.Bold = True
.Font.Color = wdColorBlueGray
End With
Else
With rngStory
'Special thanks to Helmut Weber for hlep steering us through
'dealing with bookmarked ranges
If .Bookmarks.Count = 1 Then
If Len(ActiveDocument.Bookmarks(1).Range) = Len(rngStory) Then
bkmName = .Bookmarks(1).Name
.Text = arrCounterArray(i, 0)
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Bookmarks.Add Name:=bkmName
End If
Else
.Text = arrCounterArray(i, 0) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
End If
End With
End If
rngStory.Collapse Direction:=wdCollapseEnd
arrCounterArray(i, 1) = arrCounterArray(i, 1) + 1
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrCounterArray(i, 0)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i


SearchAndReplaceInStory = arrCounterArray


End Function

 

[Chuck]

Option Explicit

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

Dim rngStory As Word.Range
Dim arrListArray
Dim arrCounterArray
Dim arrNotUsedArray
Dim strPlural As String
Dim numTerms As Long
Dim i As Long
Dim lngInstances As Long
Dim lngNotUsedInstances As Long
Dim rngRange As Range
Dim blnHideHiddenText As Boolean
Dim blnIndexExist As Boolean
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field
Dim bkmBK As Bookmark

Application.ScreenUpdating = False

'Remove Not Used List so contents not indexed
If ActiveDocument.Bookmarks.Exists("DefinedTermsIndexNotUsedList") Then
ActiveDocument.Bookmarks("DefinedTermsIndexNotUsedList").Range.Delete
End If

StripPreviousIndexing

'Store user's AutoCorrect "smart quote"
'and hidden text view options. True if enabled
blnEnableSmartQuotes = _
Options.AutoFormatAsYouTypeReplaceQuotes
blnHideHiddenText = _
ActiveDocument.ActiveWindow.View.ShowHiddenText

'Hide index field text while processing
ActiveDocument.ActiveWindow.View.ShowHiddenText = False

'Set/confirm straight quotes are applied
'(search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle

'Build Defined Terms list and create array
arrListArray = BuildArray(arrListArray)

SmartQuoteToggle

'Reports and options

'Exit macro if no Defined Terms are found
'else determine if reference to "defined term"
'should be plural
If arrListArray(0) = "" Then
MsgBox "There are no defined terms in this document." _
& vbCr & _
" Defined terms must be in bold text and enclosed " _
& "in double (not single) quotes.", vbExclamation
RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText
Exit Sub
ElseIf arrListArray(0) <> "" And UBound(arrListArray) = 0 Then
strPlural = ""
Else
strPlural = "s"
End If

numTerms = UBound(arrListArray) + 1

If MsgBox("Document contains " & numTerms & "" _
& " defined term" & strPlural & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbNo Then
RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox "Index entries have been removed from " & _
"this document.", _
vbOKOnly + vbExclamation, _
"Index entries not marked"
Exit Sub
End If

Application.ScreenRefresh

'Main routine

'Show field codes for any existing TOCs
'and INDEXs to prevent these text areas
'from being indexed
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is a TOC fields/8 is a Index field
fldField.ShowCodes = True
End If
Next fldField

'Create new counter array
'1st dimension = defined term
'2nd dimension = number of times found
ReDim arrCounterArray(UBound(arrListArray), 1)
For i = 0 To UBound(arrListArray)
arrCounterArray(i, 0) = arrListArray(i)
Next

'Cycle through each story range and mark/index terms
'Process only main, footnote and endnote stories
For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
arrCounterArray = SearchAndIndexInStory( _
rngStory, _
arrCounterArray)
End If
Set rngStory = rngStory.NextStoryRange
End If
Next

'Toggle TOC and INDEX field codes
'and clear bold in TOC fields
blnIndexExist = False 'set default
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is TOC fields/8 is Index Fields
fldField.ShowCodes = False
End If
'Identify an existing DefinedTermsIndex
'INDEX field for update options
If fldField.Type = 8 And _
InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
blnIndexExist = True
End If
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
End If
Next fldField

RestoreTextColor

'Count how many defined terms defined but
'not used (used only once)
lngNotUsedInstances = 0
Dim strNotUsed As String
For i = 0 To UBound(arrCounterArray)
If arrCounterArray(i, 1) = 1 Then
strNotUsed = strNotUsed & arrCounterArray(i, 0) & vbNewLine
lngNotUsedInstances = lngNotUsedInstances + 1
End If
Next i

If lngNotUsedInstances = 0 Then
strNotUsed = "No unused defined terms"
End If

'Insert / update index
If blnIndexExist = False Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
With rngRange
.Collapse wdCollapseEnd
.InsertBreak wdSectionBreakNextPage
.Collapse wdCollapseEnd
.Text = "INDEX OF DEFINED TERMS" & vbCr
.Bold = True
.Bookmarks.Add _
Name:="DefinedTermsIndex", _
Range:=rngRange
.Collapse wdCollapseEnd
Set fldField = .Fields.Add( _
rngRange, _
wdFieldEmpty, _
"INDEX \f ""DefinedTermsIndex""", _
False)
End With
fldField.Select
Set rngRange = Selection.Range
End If
Else
For Each fldField In ActiveDocument.Fields
With fldField
If .Type = 8 Then
If InStr(1, .Code.Text, _
"DefinedTermsIndex") > 0 Then
.Update
End If
End If
.Select
Set rngRange = Selection.Range
End With
Next fldField
' If MsgBox("Do you want to update the existing index?", _
' vbYesNo + vbQuestion) = vbYes Then
' Set rngRange = ActiveDocument.Range
' rngRange.Fields.Update
' End If
End If

NotUsedList strNotUsed, rngRange

If ActiveDocument.Bookmarks.Exists( _
"DefinedTermsIndex") Then
Selection.GoTo What:=wdGoToBookmark, _
Name:="DefinedTermsIndex"
End If

'Count how many instances of defined terms
'by adding 2nd dimension of arrCounterArray
lngInstances = 0
For i = 0 To UBound(arrCounterArray)
lngInstances = lngInstances + arrCounterArray(i, 1)
Next i

MsgBox numTerms & " defined term" & strPlural & " marked or indexed " _
& lngInstances & " times in this document.", vbOKOnly, "Done"

If lngNotUsedInstances > 1 Then
strPlural = "s were"
Else
strPlural = " was"
End If

If lngNotUsedInstances > 0 Then
MsgBox lngNotUsedInstances & " term" & strPlural & " defined but not
used.", vbOKOnly
End If

RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText

Application.ScreenRefresh
Application.ScreenUpdating = True

End Sub

Sub SmartQuoteToggle()

Dim rngStory

For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.ClearFormatting
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory

End Sub

Function BuildArray(arrListArray) As Variant

Dim rngRange As Range
Dim tempList() As String
Dim strDefinedTerm As String
Dim counter As Long
Set rngRange = ActiveDocument.Range

ReDim tempList(0)

Do
With rngRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.ClearFormatting
.Text = """*"""
.MatchWildcards = True
.Execute
'Strip quotation marks
rngRange.Start = rngRange.Start + 1
rngRange.End = rngRange.End - 1
'Confirm range start and end is bold text
If rngRange.Characters.first.Font.Bold = True _
And rngRange.Characters.last.Font.Bold = True Then
'Elimate zero length strings and erroneous white space
Select Case rngRange.Text
Case Is <> ""
rngRange.Text = Trim(rngRange.Text)
strDefinedTerm = rngRange.Text
'Check strDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If strDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = strDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found

'Remove last, empty entry if anything was added
If UBound(tempList) > 0 Then
ReDim Preserve tempList(UBound(tempList) - 1)
End If

'Define the array
arrListArray = tempList

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

End Function

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

Dim i As Long
Dim j As Long
Dim first As Long
Dim last As Long
Dim temp As Variant
Dim arrSortedList As Variant
Dim strString As String

first = LBound(arrListArray)
last = UBound(arrListArray)

ReDim arrSortedList(last)

For i = first To last
For j = i + 1 To last
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
temp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = temp
End If
Next j
Next i

For i = first To last
arrSortedList(i) = arrListArray(i)
Next i

ListSort = arrSortedList

End Function

Public Function SearchAndIndexInStory( _
ByVal rngStory As Word.Range, _
ByRef arrCounterArray As Variant)

Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim fldIndexEntry As Field

For i = 0 To UBound(arrCounterArray, 1)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrCounterArray(i, 0)
While .Execute
With rngStory
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Collapse Direction:=wdCollapseEnd
End With
arrCounterArray(i, 1) = arrCounterArray(i, 1) + 1
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrCounterArray(i, 0)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i

SearchAndIndexInStory = arrCounterArray

End Function

Sub RestoreTextColor()

Dim rngStory As Word.Range

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 StripPreviousIndexing()

Dim fldField As Field
Dim rngStory As Range
Dim rngRange As Range
Dim strString As String
Dim arrTemp

For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then 'Bypass ranges not indexed
Do Until (rngStory Is Nothing)
For Each fldField In rngStory.Fields
If rngStory.StoryType < 4 Then
If fldField.Type = 4 Then 'Index entry
If InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then

fldField.Select
ActiveDocument.Bookmarks.Add _
"XEfield", Selection.Range

Set rngRange = _
ActiveDocument.Bookmarks("XEfield").Range
rngRange.Select

strString = fldField.Code.Text
strString = Replace(strString, Chr(34), "|")
arrTemp = Split(strString, "|")
strString = arrTemp(1)

With rngRange
.Collapse wdCollapseStart
'Ignore if definition (enclosed in quotes)
.MoveStart _
wdCharacter, 0 - (Len(strString) + 1)
If rngRange.Characters.first <> Chr(34) Then
.MoveStart wdCharacter, 1
If .Font.Bold = True Then
.Font.Bold = False
.Select
End If
End If
End With

fldField.Delete
Erase arrTemp
End If
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
End If
Next

If ActiveDocument.Bookmarks.Exists("XEfield") Then
ActiveDocument.Bookmarks("XEfield").Delete
End If

End Sub

Sub RestoreUserOptions( _
ByVal blnEnableSmartQuotes As Boolean, _
ByVal blnHideHiddenText As Boolean)

Options.AutoFormatAsYouTypeReplaceQuotes = _
blnEnableSmartQuotes
ActiveDocument.ActiveWindow.View.ShowHiddenText = _
blnHideHiddenText

End Sub

Public Sub NotUsedList(ByVal strNotUsed As String, rngRange As Range)

With rngRange
.Collapse wdCollapseEnd
.Text = vbCr
.Collapse wdCollapseEnd
.Text = "DEFINED BUT NOT USED" & vbCr
.Bold = True
.InsertAfter (strNotUsed)
.MoveEnd wdCharacter, Len(.Text) + Len(strNotUsed)
End With

ActiveDocument.Bookmarks.Add _
Name:="DefinedTermsIndexNotUsedList", _
Range:=rngRange

End Sub

 

[Chuck]

Hi GG

Early in this thread Greg mentioned "rights" to the code. Greg and I both
feel the GPL is appropriate. Essentially the GPL allows anyone to freely use
the code but with restrictions. Below is a brief overview of the concept of
the GPL, links to the exact terms FAQ etc appear at the end of this message:

"When we speak of free software, we are referring to freedom, not price. Our
General Public Licenses are designed to make sure that you have the freedom
to distribute copies of free software (and charge for this service if you
wish), that you receive source code or can get it if you want it, that you
can change the software or use pieces of it in new free programs; and that
you know you can do these things.
***
For example, if you distribute copies of such a program, whether gratis or
for a fee, you must give the recipients all the rights that you have. You
must make sure that they, too, receive or can get the source code. And you
must show them these terms so they know their rights."

Since this code is already de facto freely available (anyone can access it
in a public newsgroup), the GPL makes sense as a way to protect the code from
being unfairly "privatised" by some third party, allowing people to
collaborate on it, improve it, adapt it to their own purposes, etc.

Are you agreeable to this code being covered by the GPL?

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/).

Chuck

 

[Greg]

Chuck,

I like everything except I want to leave the bookmark handler in the
code. It works as intended "should" the user want to set .MatchCase to
False. Otherwise it is transparent.

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

Dim rngStory As Word.Range
Dim arrListArray
Dim arrCounterArray
Dim arrNotUsedArray
Dim strPlural As String
Dim numTerms As Long
Dim i As Long
Dim lngInstances As Long
Dim lngNotUsedInstances As Long
Dim rngRange As Range
Dim blnHideHiddenText As Boolean
Dim blnIndexExist As Boolean
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field
Dim bkmBK As Bookmark


Application.ScreenUpdating = False


'Remove Not Used List so contents not indexed
If ActiveDocument.Bookmarks.Exists("DefinedTermsIndexNotUsedList") Then
ActiveDocument.Bookmarks("DefinedTermsIndexNotUsedList").Range.Delete
End If


StripPreviousIndexing


'Store user's AutoCorrect "smart quote"
'and hidden text view options. True if enabled
blnEnableSmartQuotes = _
Options.AutoFormatAsYouTypeReplaceQuotes
blnHideHiddenText = _
ActiveDocument.ActiveWindow.View.ShowHiddenText


'Hide index field text while processing
ActiveDocument.ActiveWindow.View.ShowHiddenText = False


'Set/confirm straight quotes are applied
'(search fails otherwise)
Options.AutoFormatAsYouTypeReplaceQuotes = False
SmartQuoteToggle


'Build Defined Terms list and create array
arrListArray = BuildArray(arrListArray)


SmartQuoteToggle


'Reports and options


'Exit macro if no Defined Terms are found
'else determine if reference to "defined term"
'should be plural
If arrListArray(0) = "" Then
MsgBox "There are no defined terms in this document." _
& vbCr & _
" Defined terms must be in bold text and enclosed " _
& "in double (not single) quotes.", vbExclamation
RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText
Exit Sub
ElseIf arrListArray(0) <> "" And UBound(arrListArray) = 0 Then
strPlural = ""
Else
strPlural = "s"
End If


numTerms = UBound(arrListArray) + 1


If MsgBox("Document contains " & numTerms & "" _
& " defined term" & strPlural & "." _
& vbCr & "Do you want to continue processing?", _
vbInformation + vbYesNo) = vbNo Then
RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText
MsgBox "Index entries have been removed from " & _
"this document.", _
vbOKOnly + vbExclamation, _
"Index entries not marked"
Exit Sub
End If


Application.ScreenRefresh


'Main routine


'Show field codes for any existing TOCs
'and INDEXs to prevent these text areas
'from being indexed
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is a TOC fields/8 is a Index field
fldField.ShowCodes = True
End If
Next fldField


'Create new counter array
'1st dimension = defined term
'2nd dimension = number of times found
ReDim arrCounterArray(UBound(arrListArray), 1)
For i = 0 To UBound(arrListArray)
arrCounterArray(i, 0) = arrListArray(i)
Next


'Cycle through each story range and mark/index terms
'Process only main, footnote and endnote stories
For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then
If rngStory.StoryLength >= 2 Then
arrCounterArray = SearchAndIndexInStory( _
rngStory, _
arrCounterArray)
End If
Set rngStory = rngStory.NextStoryRange
End If
Next


'Toggle TOC and INDEX field codes
'and clear bold in TOC fields
blnIndexExist = False 'set default
For Each fldField In ActiveDocument.Fields
If fldField.Type = 13 Or fldField.Type = 8 Then
'13 is TOC fields/8 is Index Fields
fldField.ShowCodes = False
End If
'Identify an existing DefinedTermsIndex
'INDEX field for update options
If fldField.Type = 8 And _
InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then
blnIndexExist = True
End If
If fldField.Type = wdFieldTOC Then
fldField.Result.Font.Bold = False
End If
Next fldField


RestoreTextColor


'Count how many defined terms defined but
'not used (used only once)
lngNotUsedInstances = 0
Dim strNotUsed As String
For i = 0 To UBound(arrCounterArray)
If arrCounterArray(i, 1) = 1 Then
strNotUsed = strNotUsed & arrCounterArray(i, 0) & vbNewLine
lngNotUsedInstances = lngNotUsedInstances + 1
End If
Next i


If lngNotUsedInstances = 0 Then
strNotUsed = "No unused defined terms"
End If


'Insert / update index
If blnIndexExist = False Then
If MsgBox("Do you want to create your index now?", _
vbYesNo + vbQuestion) = vbYes Then
Set rngRange = ActiveDocument.Range
With rngRange
.Collapse wdCollapseEnd
.InsertBreak wdSectionBreakNextPage
.Collapse wdCollapseEnd
.Text = "INDEX OF DEFINED TERMS" & vbCr
.Bold = True
.Bookmarks.Add _
Name:="DefinedTermsIndex", _
Range:=rngRange
.Collapse wdCollapseEnd
Set fldField = .Fields.Add( _
rngRange, _
wdFieldEmpty, _
"INDEX \f ""DefinedTermsIndex""", _
False)
End With
fldField.Select
Set rngRange = Selection.Range
End If
Else
For Each fldField In ActiveDocument.Fields
With fldField
If .Type = 8 Then
If InStr(1, .Code.Text, _
"DefinedTermsIndex") > 0 Then
.Update
End If
End If
.Select
Set rngRange = Selection.Range
End With
Next fldField
' If MsgBox("Do you want to update the existing index?", _
' vbYesNo + vbQuestion) = vbYes Then
' Set rngRange = ActiveDocument.Range
' rngRange.Fields.Update
' End If
End If


NotUsedList strNotUsed, rngRange


If ActiveDocument.Bookmarks.Exists( _
"DefinedTermsIndex") Then
Selection.GoTo What:=wdGoToBookmark, _
Name:="DefinedTermsIndex"
End If


'Count how many instances of defined terms
'by adding 2nd dimension of arrCounterArray
lngInstances = 0
For i = 0 To UBound(arrCounterArray)
lngInstances = lngInstances + arrCounterArray(i, 1)
Next i


MsgBox numTerms & " defined term" & strPlural & " marked or indexed " _
& lngInstances & " times in this document.", vbOKOnly, "Done"


If lngNotUsedInstances > 1 Then
strPlural = "s were"
Else
strPlural = " was"
End If


If lngNotUsedInstances > 0 Then
MsgBox lngNotUsedInstances & " term" & strPlural & " defined but not
" _
& "used.", vbOKOnly
End If


RestoreUserOptions _
blnEnableSmartQuotes, _
blnHideHiddenText


Application.ScreenRefresh
Application.ScreenUpdating = True


End Sub


Sub SmartQuoteToggle()


Dim rngStory


For Each rngStory In ActiveDocument.StoryRanges
Do
If rngStory.StoryLength >= 2 Then
With rngStory.Find
.ClearFormatting
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next rngStory


End Sub


Function BuildArray(arrListArray) As Variant


Dim rngRange As Range
Dim tempList() As String
Dim strDefinedTerm As String
Dim counter As Long
Set rngRange = ActiveDocument.Range


ReDim tempList(0)


Do
With rngRange.Find
'Find Defined Terms (i.e., terms quoted an in bold text)
.ClearFormatting
.Text = """*"""
.MatchWildcards = True
.Execute
'Strip quotation marks
rngRange.Start = rngRange.Start + 1
rngRange.End = rngRange.End - 1
'Confirm range start and end is bold text
If rngRange.Characters.first.Font.Bold = True _
And rngRange.Characters.last.Font.Bold = True Then
'Elimate zero length strings and erroneous white space
Select Case rngRange.Text
Case Is <> ""
rngRange.Text = Trim(rngRange.Text)
strDefinedTerm = rngRange.Text
'Check strDefinedTerm is already part of the tempList array
For counter = LBound(tempList) To UBound(tempList)
If strDefinedTerm = tempList(counter) Then
'If yes, skip to next
GoTo continue
End If
Next counter
'Otherwise, add to array
tempList(UBound(tempList)) = strDefinedTerm
'Prepare for next entry
ReDim Preserve tempList(UBound(tempList) + 1)
Case Else
'Do nothing
End Select
End If
continue:
'Step range past last found quotation mark
rngRange.End = rngRange.End + 1
rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found


'Remove last, empty entry if anything was added
If UBound(tempList) > 0 Then
ReDim Preserve tempList(UBound(tempList) - 1)
End If


'Define the array
arrListArray = tempList


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


End Function


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


Dim i As Long
Dim j As Long
Dim first As Long
Dim last As Long
Dim temp As Variant
Dim arrSortedList As Variant
Dim strString As String


first = LBound(arrListArray)
last = UBound(arrListArray)


ReDim arrSortedList(last)


For i = first To last
For j = i + 1 To last
If Len(arrListArray(i)) < Len(arrListArray(j)) Then
temp = arrListArray(j)
arrListArray(j) = arrListArray(i)
arrListArray(i) = temp
End If
Next j
Next i


For i = first To last
arrSortedList(i) = arrListArray(i)
Next i


ListSort = arrSortedList


End Function
Public Function SearchAndIndexInStory( _
ByVal rngStory As Word.Range, _
ByRef arrCounterArray As Variant)


Dim i As Long
Dim j As Long 'counts indexing action for each term in array
Dim fldIndexEntry As Field
Dim bkmName As String

For i = 0 To UBound(arrCounterArray, 1)
Selection.HomeKey Unit:=wdStory
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
'.MatchCase = False swap with true to index all instances
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindStop
.Text = arrCounterArray(i, 0)
While .Execute
If .MatchCase = True Then
With rngStory
.Font.Bold = True
.Font.Color = wdColorBlueGray
End With
Else
With rngStory
'Special thanks to Helmut Weber for hlep steering us
through
'dealing with bookmarked ranges
If .Bookmarks.Count = 1 Then
If Len(rngStory.Bookmarks(1).Range) = Len(rngStory) Then
bkmName = .Bookmarks(1).Name
.Text = arrCounterArray(i, 0)
.Font.Bold = True
.Font.Color = wdColorBlueGray
.Bookmarks.Add Name:=bkmName
Else
.Text = arrCounterArray(i, 0) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
End If
Else
.Text = arrCounterArray(i, 0) 'vice .Text
.Font.Bold = True
.Font.Color = wdColorBlueGray
End If
End With
End If
rngStory.Collapse Direction:=wdCollapseEnd
arrCounterArray(i, 1) = arrCounterArray(i, 1) + 1
If rngStory.Font.Color <> wdColorBlueGray Then
Set fldIndexEntry = _
ActiveDocument.Indexes.MarkEntry _
(Range:=rngStory, _
Entry:=Trim(arrCounterArray(i, 0)))
fldIndexEntry.Code.Text = _
fldIndexEntry.Code.Text & _
"\f ""DefinedTermsIndex"" "
End If
Wend
End With
rngStory.Expand Unit:=wdStory
Next i


SearchAndIndexInStory = arrCounterArray


End Function



Sub RestoreTextColor()


Dim rngStory As Word.Range


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 StripPreviousIndexing()


Dim fldField As Field
Dim rngStory As Range
Dim rngRange As Range
Dim strString As String
Dim arrTemp


For Each rngStory In ActiveDocument.StoryRanges
If rngStory.StoryType < 4 Then 'Bypass ranges not indexed
Do Until (rngStory Is Nothing)
For Each fldField In rngStory.Fields
If rngStory.StoryType < 4 Then
If fldField.Type = 4 Then 'Index entry
If InStr(1, fldField.Code.Text, _
"\f ""DefinedTermsIndex"" ") > 0 Then


fldField.Select
ActiveDocument.Bookmarks.Add _
"XEfield", Selection.Range


Set rngRange = _
ActiveDocument.Bookmarks("XEfield").Range
rngRange.Select


strString = fldField.Code.Text
strString = Replace(strString, Chr(34), "|")
arrTemp = Split(strString, "|")
strString = arrTemp(1)


With rngRange
.Collapse wdCollapseStart
'Ignore if definition (enclosed in quotes)
.MoveStart _
wdCharacter, 0 - (Len(strString) + 1)
If rngRange.Characters.first <> Chr(34) Then
.MoveStart wdCharacter, 1
If .Font.Bold = True Then
.Font.Bold = False
.Select
End If
End If
End With


fldField.Delete
Erase arrTemp
End If
End If
End If
Next fldField
Set rngStory = rngStory.NextStoryRange
Loop
End If
Next


If ActiveDocument.Bookmarks.Exists("XEfield") Then
ActiveDocument.Bookmarks("XEfi­eld").Delete
End If


End Sub


Sub RestoreUserOptions( _
ByVal blnEnableSmartQuotes As Boolean, _
ByVal blnHideHiddenText As Boolean)


Options.AutoFormatAsYouTypeReplaceQuotes = _
blnEnableSmartQuotes
ActiveDocument.ActiveWindow.View.ShowHiddenText = _
blnHideHiddenText


End Sub


Public Sub NotUsedList(ByVal strNotUsed As String, rngRange As Range)


With rngRange
.Collapse wdCollapseEnd
.Text = vbCr
.Collapse wdCollapseEnd
.Text = "DEFINED BUT NOT USED" & vbCr
.Bold = True
.InsertAfter (strNotUsed)
.MoveEnd wdCharacter, Len(.Text) + Len(strNotUsed)
End With


ActiveDocument.Bookmarks.Add _
Name:="DefinedTermsIndexNotUsedList", _
Range:=rngRange


End Sub

 

[Chuck]

Hi Greg

Sorry, but indexing is different from replacing. It's one thing to bold
face all instances (regardless of case, ie match case false) but if the code
changes the case then it should throw up a very clear warning that that's
what it's doing and give the user the option of declining. I have seen tears
shed (and jobs threatened) because of what look like trivial things to the
layman's eyes, such as unmonitored global changes (eg changing the case of
all instances of a word). It's not a trivial issue and needs to be very
clearly flagged before proceeding.

I understand that the OP wanted a global replace, but this code is no longer
OP specific and hasn't been for some time (certainly not since I got
involved).

In any case people now have two versions they can use, my version which
bolds and indexes but does not change case, and yours which bolds, indexes
and changes case if the user chooses to make the search case insensitive.

Cheers and good working with you!

Chuck

 

[Greg]

Chuck,

It has been good workig with you too! I have certainly learned a great
deal in trying to address each of the problems that cropped up along
the way.

I am not inflexible. Let's call "your" version "our" version for the
purpose of the GPL and call it done. In your opinion, and I don't need
a second, that seems to provide a near standard solution for indexing
legal text.

I have both versions here and will likely never use either except for
reference.

That said, simply removing:

..Text = arrCounterArray(i, 0)

From the three condition in the SearchAndIndexInStory function might

save both tears and jobs and still apply bold face to all instances
regardless case

I guess I have three versions now.

If you see struggling with other code along the way, please throw me a
lifeline.

Cheers.