Option Explicit

Public Const open_smart_quote As String = "“"                       ' Smart quote entered using ALT+0147
Public Const not_open_smart_quote As String = "([!“])"
Public Const close_smart_quote As String = "”"                      ' Smart quote entered using ALT+0148
Public Const capitalised_word As String = "([A-Z])(*)"              ' Any sequence of characters starting with a Capital letter
Public Const end_of_capitalised_word As String = "([^13 ,.-:;])"    ' Possible characters that end a definition if closing smart quote omitted
Public Const breaking_space As String = " "
Public Const lcase_letters As String = "abcdefghijklmnopqrstuvwxyz"
Public Const ucase_letters As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Public search_doc As Word.Document
Public quoted_definitions As Scripting.Dictionary

Sub annotate_definitions_in_a_doc()

    Set search_doc = ActiveDocument
    Set quoted_definitions = New Scripting.Dictionary
    compile_list_of_quoted_definitions
    check_that_definitions_are_used
    highlight_unused_definitions
    highlight_capitalised_phrases_with_no_definition
    
End Sub

Sub compile_list_of_quoted_definitions()

Dim search_range As Word.Range

    Set search_range = search_doc.StoryRanges(wdMainTextStory)

    With search_range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Text = open_smart_quote & capitalised_word & end_of_capitalised_word
        .Execute
        Do Until search_range.Text = vbNullString
            update_search_range_to_whole_capitalised_phrase search_range
            update_search_range_to_capitalised_phrase_text search_range
            do_actions_for_quoted_text search_range
            search_range.Move unit:=wdWord
            .Execute
        Loop
    End With
   
End Sub

Sub do_actions_for_quoted_text(this_range As Word.Range)

    ' Check to see if a definition we have just found already exists
    If quoted_definitions.Exists(this_range.Text) Then
        search_doc.Comments.Add Range:=this_range, Text:="Duplicate definition?"
        Exit Sub
    End If

    If Not this_range.Next(unit:=wdCharacter).Text = close_smart_quote Then
        ' comment out the line below if you don't want comments in the document
        search_doc.Comments.Add Range:=this_range.Duplicate, Text:="Missing closing quote"
        ' Uncomment the next line to add a closing smart quote if one is missing.
        ' this_range.InsertAfter Text:=close_smart_quote
    End If
    
    quoted_definitions.Add Key:=this_range.Text, Item:=True
    
End Sub

Sub update_search_range_to_whole_capitalised_phrase(this_range As Word.Range)
    ' We didn't include the close_smart_quote in the search but if present
    ' it will be the second to last charcter in the search range
    ' so we will only extend the range if no close_smart_quote is present in this_range.text
    If InStr(this_range.Text, close_smart_quote) = 0 Then
        ' The last character of this_range will be a character from end_of_capitalised_word.
        ' We only want to extend the range if the last character is a breaking_space
        ' Two seperate if statemdnts are used because this provides greater flexibility
        ' if we need to make tweaks later on.
        If this_range.Characters.Last.Text = breaking_space Then
            Do While InStr(ucase_letters, this_range.Next(unit:=wdWord).Characters.First.Text) > 0
                this_range.MoveEnd unit:=wdWord, Count:=1
            Loop
        End If
    End If
    
End Sub

Sub update_search_range_to_capitalised_phrase_text(this_range As Word.Range)
    ' This subroutine is used on two occasions with slightly different requirements
    ' consequently we test for the relevant characters before adjusting the range
    ' as in the second use the characters definitiely won't be included in the range
    
    If this_range.Characters.First.Text = open_smart_quote Then
        this_range.MoveStart unit:=wdCharacter, Count:=1              ' Eliminate the start_smart_quote
    End If
    ' check if they are present before adjusting the end of the range.
    If InStr(end_of_capitalised_word, this_range.Characters.Last.Text) > 0 Then
        this_range.MoveEnd unit:=wdCharacter, Count:=-1               ' Eliminate the terminating character
    End If
    If this_range.Characters.Last.Text = close_smart_quote Then
        this_range.MoveEnd unit:=wdCharacter, Count:=-1           ' If present remove the close_smart_quote
    End If
    ' this_range should now encompass only the text of the definition

End Sub
    
Sub check_that_definitions_are_used()

Dim definition As Variant
Dim search_range As Word.Range

    ' We can now use the scripting.dictionary of defined terms to check if they
    ' actually occur in the document
    ' if we don't find a definition used in the document then the item value
    ' of the definition in the dictionary will be set to false.
    
    For Each definition In quoted_definitions.keys
        Set search_range = search_doc.StoryRanges(wdMainTextStory)
    
        With search_range.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = True
            .MatchCase = True
            .Wrap = wdFindStop
            .Text = not_open_smart_quote & definition & end_of_capitalised_word
            .Execute
            If Not .Found Then
                quoted_definitions(definition) = False
            End If
        End With
            
    Next
    
End Sub

Sub highlight_unused_definitions()
Dim definition As Variant
Dim search_range As Word.Range
Dim search_text As String
Dim replace_text As String

    replace_text = "[\1\2]"
    For Each definition In quoted_definitions.keys
        If Not quoted_definitions(definition) Then
            Set search_range = search_doc.StoryRanges(wdMainTextStory)
            search_range.Select
            search_text = "(" & open_smart_quote & ")" & "(" & definition & ")" ' & end_of_capitalised_word
            With search_range.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .MatchWildcards = True
                .Wrap = wdFindStop
                .Text = search_text
                .Replacement.Text = replace_text
                .Replacement.Highlight = True
                .Execute Replace:=wdReplaceOne
                Set search_range = Nothing
                ' if preferred you could add here the code to add a comment rqather than highlight the text
            End With
        End If
    Next
End Sub

Sub highlight_capitalised_phrases_with_no_definition()

Dim search_range As Word.Range

    Set search_range = search_doc.StoryRanges(wdMainTextStory)

    With search_range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Text = capitalised_word & end_of_capitalised_word
        .Execute
        Do Until search_range.Text = vbNullString
            update_search_range_to_whole_capitalised_phrase search_range
            update_search_range_to_capitalised_phrase_text search_range
            do_actions_for_capitalised_phrase search_range
            search_range.Move unit:=wdWord
            .Execute
        Loop
    End With

End Sub

Sub do_actions_for_capitalised_phrase(this_range As Word.Range)

    If Not quoted_definitions.Exists(this_range.Text) Then
        search_doc.Comments.Add Range:=this_range.Duplicate, Text:="Capitalised phrase with no corresponding definition"
        ' alternatively, if a highlihght if preferred over a comment
        ' this_range.HighlightColorIndex=wdRed
    End If
             
End Sub