Sub HighlightDefs()
HighlightWork1.Show vbModeless
End Sub
Private Sub cmdAll_Click()
'1. Highlight Defined Terms
Dim i As Integer
Dim j As Integer
Dim R1 As Integer
Dim R2 As Integer
Dim R3 As Integer
Dim r4 As Integer
Dim oRng As Word.Range
Dim oRng2 As Word.Range
Dim NumCharsBefore As Long, NumCharsAfter As Long, LengthsAreEqual As Boolean
Dim StrFind As String
Dim StrReplace As String
Dim StrReplace2 As String
Dim StrFind2 As String
Dim Length As Integer
Dim varText As String
Dim myRange As Range
Dim char As String
Dim myNum As Integer
Dim myNum2 As Integer
Dim myNum3 As Integer
Dim bSmtQt As Boolean
i = 0
j = 0
R1 = 0
R2 = 0
R3 = 0
r4 = 0
Dim nCount As Long
nCount = 0
ActiveDocument.UndoClear
On Error GoTo Out3
ActiveDocument.ActiveWindow.View.Type = wdPrintView
'Application.ScreenUpdating = False
'replace straight quotes with smart quotes
bSmtQt = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = True
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
If ActiveDocument.Footnotes.Count >= 1 Then
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Options.AutoFormatAsYouTypeReplaceQuotes = bSmtQt
End If
With Selection
.HomeKey wdStory
End With
'find unmatched quotes
Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
With oPara.Range
If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
.Select
MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
If varText = vbOK Then
Exit Sub
End If
Unload Me
Exit Sub
End If
If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
.Select
MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
If varText = vbOK Then
Exit Sub
End If
Unload Me
Exit Sub
End If
End With
Next
Dim oFoot As Footnote
For Each oFoot In ActiveDocument.Footnotes
With oFoot.Range
If (Len(.Text) - Len(Replace(.Text, Chr(34), vbNullString))) Mod 2 <> 0 Then
.Select
MsgBox "Selected paragraph has unmatched plain quotes", vbExclamation
If varText = vbOK Then
Exit Sub
End If
Unload Me
Exit Sub
End If
If Len(Replace(.Text, Chr(147), vbNullString)) <> Len(Replace(.Text, Chr(148), vbNullString)) Then
.Select
MsgBox "Selected paragraph has unmatched smart quotes", vbExclamation
If varText = vbOK Then
Exit Sub
End If
Unload Me
Exit Sub
End If
End With
Next
ActiveDocument.UndoClear
i = 0
'insert text to mark end of replacements
Selection.HomeKey unit:=wdStory
Selection.TypeText Text:=Chr(147) & "xyxy" & Chr(148) & " "
Do
'A. find quote for next term
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^0147"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Set myRange = Selection.Range
If Selection.Range.HighlightColorIndex = wdTurquoise Then
With Selection.Find
.Text = "^0148"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^0147"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Else
End If
'2. find close quote and select
Selection.Extend
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^0148"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.ExtendMode = False
StrFind = Selection.Text
StrReplace = Selection.Text
Length = Len(StrReplace) - 2
'set second variable for plural
If Length > 1 Then
StrFind2 = Mid$(StrReplace, 1, Length) & Chr(148)
StrReplace2 = Mid$(StrReplace, 1, Length) & Chr(148)
Else
End If
'skip certain words
If Mid$(StrFind, 2, 2) = "or" And Len(StrFind) = 4 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "or," And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 2) = "to" And Len(StrFind) = 4 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "to," And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Len(StrFind) = 3 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "and" And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 4) = "and," And Len(StrFind) = 6 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "our" And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 4) = "our," And Len(StrFind) = 6 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 2) = "we" And Len(StrFind) = 4 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "we," And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 2) = "us" And Len(StrFind) = 4 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
If Mid$(StrFind, 2, 3) = "us," And Len(StrFind) = 5 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
End If
Set myRange = Selection.Range
'check if back at the beginning
If myRange = Chr(147) & "xyxy" & Chr(148) _
Or myRange = Chr(147) & "Xyxy" & Chr(148) _
Or myRange = Chr(147) & "XYXY" & Chr(148) Then
GoTo Skip3
Else
End If
'skip if string is too long
If Len(StrFind) > 254 Then
Selection.Collapse Direction:=wdCollapseEnd
GoTo Skip
Else
End If
With Selection
.HomeKey wdStory
'replace terms defined more than once
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(FindText:=StrFind, _
MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdTurquoise
i = i + 1
ActiveDocument.UndoClear
Loop
Selection.HomeKey wdStory
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng2 = Selection.Range
oRng2.HighlightColorIndex = wdTurquoise
j = j + 1
ActiveDocument.UndoClear
Loop
If ActiveDocument.Footnotes.Count >= 1 Then
ActiveDocument.StoryRanges(wdFootnotesStory).Select
Selection.HomeKey
Do While .Execute(FindText:=StrFind, _
MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdTurquoise
i = i + 1
ActiveDocument.UndoClear
Loop
Selection.HomeKey
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=True, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng2 = Selection.Range
oRng2.HighlightColorIndex = wdTurquoise
j = j + 1
ActiveDocument.UndoClear
Loop
End If
ActiveDocument.StoryRanges(wdMainTextStory).Select
Selection.HomeKey
R1 = i
R3 = j
'remove highlighting if defined just once
If i > 0 And j > 0 Then
ElseIf i <= 1 And j = 0 Then
oRng.HighlightColorIndex = wdNone
ElseIf i = 0 And j <= 1 Then
oRng2.HighlightColorIndex = wdNone
Else
End If
End With
End With
i = 0
j = 0
'C. go back to last term
myRange.Select
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^0147"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.Extend
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^0148"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.ExtendMode = False
StrFind = Selection.Text
StrReplace = Selection.Text
'shorten selection by one character to handle plurals
If Len(StrReplace) > 3 Then
Length = Len(StrReplace) - 1
Else
Length = Len(StrReplace)
End If
StrFind2 = Mid$(StrReplace, 1, Length)
StrReplace2 = Mid$(StrReplace, 1, Length)
Set myRange = Selection.Range
With Selection
.HomeKey wdStory
'highlight all copies yellow
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdYellow
i = i + 1
ActiveDocument.UndoClear
Loop
If ActiveDocument.Footnotes.Count >= 1 Then
ActiveDocument.StoryRanges(wdFootnotesStory).Select
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdYellow
i = i + 1
ActiveDocument.UndoClear
Loop
End If
ActiveDocument.StoryRanges(wdMainTextStory).Select
R2 = i
End With
End With
'check if term defined, but not used, and highlight red
If R2 = R1 + R3 Then
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdRed
i = i + 1
ActiveDocument.UndoClear
Loop
If ActiveDocument.Footnotes.Count >= 1 Then
ActiveDocument.StoryRanges(wdFootnotesStory).Select
Selection.HomeKey
Do While .Execute(FindText:=StrFind2, _
MatchCase:=False, MatchWholeWord:=False, MatchWildcards:=False, _
Wrap:=wdFindStop, Forward:=True) = True
Set oRng = Selection.Range
oRng.HighlightColorIndex = wdRed
i = i + 1
ActiveDocument.UndoClear
Loop
End If
ActiveDocument.StoryRanges(wdMainTextStory).Select
End With
End With
End If
i = 0
R1 = 0
R2 = 0
myRange.Select
If myRange = Chr(147) & "xyxy" & Chr(148) _
Or myRange = Chr(147) & "Xyxy" & Chr(148) _
Or myRange = Chr(147) & "XYXY" & Chr(148) Then
GoTo Skip3
Else
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
Skip:
ActiveDocument.UndoClear
Loop
Skip3:
'FOOTNOTE LOOP
SkipFootnote:
Set oRng = Nothing
Set oRng2 = Nothing
StrFind = vbNullString
StrReplace = vbNullString
StrReplace2 = vbNullString
StrFind2 = vbNullString
char = vbNullString
Call ClearFindAndReplaceParameters
Skip2:
'insert text box in header
Selection.HomeKey unit:=wdStory
Selection.MoveRight unit:=wdWord, Count:=3, Extend:=wdExtend
Selection.Delete unit:=wdCharacter, Count:=1
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddTextbox(msoTextOrientationHorizontal, _
99#, 28.8, 144#, 171#).Select
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.TypeText Text:="cyan quotes = term defined more than once"
Selection.TypeParagraph
Selection.TypeText Text:="yellow = all instances of defined term"
Selection.TypeParagraph
Selection.TypeText Text:="red = term defined, but not used"
Selection.TypeParagraph
Selection.TypeText Text:="purple = possible undefined terms"
Selection.TypeParagraph
Selection.TypeText Text:="green = fields and selected references"
Selection.WholeStory
Selection.Font.Size = 8
Selection.ShapeRange.Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 53.5
Selection.ShapeRange.Width = 215.3
Selection.ShapeRange.Left = 99.35
Selection.ShapeRange.Top = 28.8
Selection.ShapeRange.TextFrame.MarginLeft = 7.2
Selection.ShapeRange.TextFrame.MarginRight = 7.2
Selection.ShapeRange.TextFrame.MarginTop = 1.44
Selection.ShapeRange.TextFrame.MarginBottom = 1.44
Selection.ShapeRange.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionColumn
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionParagraph
Selection.ShapeRange.Left = InchesToPoints(0.13)
Selection.ShapeRange.Top = InchesToPoints(-0.1)
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.LayoutInCell = True
Selection.ShapeRange.WrapFormat.AllowOverlap = True
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
Selection.ShapeRange.WrapFormat.Type = 3
Selection.ShapeRange.ZOrder 4
Selection.ShapeRange.TextFrame.AutoSize = False
Selection.ShapeRange.TextFrame.WordWrap = True
Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Application.ScreenUpdating = True
ActiveDocument.UndoClear
Selection.Find.ClearFormatting
Call ClearFindAndReplaceParameters
Exit Sub
Out3:
End Sub