Option Explicit

' Vetted by Rubberduck  http://rubberduckvba.com/

Public Const open_quote                         As String = "("")"         ' Smart quote entered using ALT+0147
Public Const close_quote                        As String = """"           ' Smart quote entered using ALT+0148
Public Const capitalised_word                   As String = "([$£A-Za-z€])([0-9A-Za-z]{1,})" ' Any sequence of characters starting with a Capital letter
Public Const definition_other_chars             As String = " ''(),-:;[\]`ofs–—"

Public search_doc                               As Word.Document
Public quoted_definitions                       As Object


Public Sub annotate_definitions_in_a_doc()
    
    Application.ScreenUpdating = False
    Set search_doc = ActiveDocument
    Set quoted_definitions = CreateObject("Scripting.Dictionary")
    compile_list_of_quoted_definitions
    check_that_definitions_are_used
    highlight_unused_definitions
    create_definitions_document
    Application.ScreenUpdating = True
    
End Sub


Private Sub create_definitions_document()

Dim my_definitions_doc                          As Word.Document
Dim my_definition                               As Variant
Dim my_definitions                              As Variant

    Set my_definitions_doc = Documents.Add
    my_definitions = quoted_definitions.keys
    
    For Each my_definition In my_definitions
    
        my_definitions_doc.Content.InsertAfter Text:=my_definition & vbTab & quoted_definitions.Item(my_definition) & vbCrLf
        
    Next
    
    my_definitions_doc.Content.Select
    
    Selection.ConvertToTable Separator:=wdSeparateByTabs
    
    With Selection.Tables(1)
    
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        
    End With
    
    my_definitions_doc.SaveAs2 Replace(search_doc.FullName, ".do", "_definitions.do")
    
End Sub


Private Sub compile_list_of_quoted_definitions()

Dim search_range                                As Word.Range
Dim found_range                                 As Word.Range

    Set search_range = search_doc.StoryRanges(wdMainTextStory)

    With search_range
    
        With .Find
        
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = True
            .Wrap = wdFindStop
            .Text = open_quote & capitalised_word
            .Execute
        
        End With
            
        Do While .Find.Found
        
            DoEvents
            Set found_range = .Duplicate
            update_search_range_to_whole_capitalised_phrase found_range
            do_actions_for_quoted_text found_range
            .Collapse direction:=wdCollapseEnd
            .Move unit:=wdCharacter, Count:=1
            .Find.Execute
            
        Loop
        
    End With
    
End Sub


Private Sub do_actions_for_quoted_text(ByRef this_range As Word.Range)

    this_range.Select
    ' 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
    
    quoted_definitions.Add Key:=this_range.Text, Item:=True
    this_range.Font.ColorIndex = wdRed
   
End Sub


Private Sub update_search_range_to_whole_capitalised_phrase(ByRef this_range As Word.Range)
' The found range starts with a double quote which we don't need
' so move the start of the range past the double quote
    
    this_range.MoveStart unit:=wdCharacter
    
    ' We only searched for alpha characters after the opening quote
    ' is the next character a double quote
    If this_range.Characters.Last.Next.Text = close_quote Then
    
        Exit Sub
        
    End If
    
    ' the next character is not a quote so we need to check if it is a
    ' non alpha character that can be included in a definition or a capital
    ' if not then add comment about incorrect definition
    
    Do
    
        DoEvents
        ' " (),-:;[\]`of–—"
        If Not ( _
           (InStr(definition_other_chars, this_range.Characters.Last.Next.Text) > 0) _
           Or (this_range.Characters.Last.Next.Text Like "[A-Za-z]")) _
        Then
        
            this_range.Comments.Add this_range, "Definition missing closing quote"
            Exit Sub
            
        End If
        
        ' The next character is legal so look for the next word
        ' first skip over any permitted non-alpha characters
        this_range.MoveEndWhile cset:=definition_other_chars
       
        'Check for Capital or double quote
       
        If this_range.Characters.Last.Next.Text Like "[!""0-9A-Za-z]" Then
        
            this_range.Comments.Add this_range, "Definition missing closing quote"
            Exit Sub
            
        End If

        this_range.MoveEnd unit:=wdWord
        
    Loop Until this_range.Characters.Last.Next = """"

End Sub


Private Sub check_that_definitions_are_used()

Dim definition                                  As Variant
Dim definitions                                 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.
    
    definitions = quoted_definitions.keys
    
    For Each definition In definitions
    
        DoEvents
        Set search_range = search_doc.StoryRanges(wdMainTextStory)
    
        With search_range.Find
        
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = True
            .MatchCase = True
            .Wrap = wdFindStop
            .Text = definition
            .Execute
            If Not .Found Then
            
                quoted_definitions(definition) = False
                
            End If
            
        End With
            
    Next
    
End Sub


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

    replace_text = "[\1\2]"
    definitions = quoted_definitions.keys
    
    For Each definition In definitions
    
        DoEvents
        
        If Not quoted_definitions(definition) Then
        
            Set search_range = search_doc.StoryRanges(wdMainTextStory)
            search_range.Select
            search_text = "(" & open_quote & ")" & "(" & definition & ")"
            
            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