Create definition for glossary (Tabe Of Contents #8)

Sub GLOSSARY()
'
' GLOSSARY Macro
'
'
Dim strMark As String
Dim strDEf As String
''Dim newdoc As New Document
'Dim myrange As Range
Dim I As Integer

Dim Curdoc

Set Curdoc = ActiveDocument

''trim up selection
Do While Selection.Characters(Selection.Characters.Count) = " " And Selection.Characters.Count > 1
   Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Loop

strMark = Selection.Text
 
If strMark = "" Then
   MsgBox "Select some text to mark first", vbCritical, "Error"
   Exit Sub
End If

   Selection.Font.Bold = True
   Selection.Font.Italic = True
 
   strDEf = InputBox("Definition for " & strMark, "Define Term", vbOK) ''get definition
 
   strDEf = strMark & "-" & strDEf
Dim x As Field
Set x = Curdoc.TablesOfAuthorities.MarkCitation(Range:=Selection.Range, _
      ShortCitation:=strDEf, LongCitation:= _
      strDEf, LongCitationAutoText:= _
      "MarkCitation3", Category:=8)
   
   ActiveWindow.ActivePane.View.ShowAll = True
 
   x.Select
 
   ''Format definition with find/replace
   Dim strField
   strField = "\l " & VBQT & strMark
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find.Replacement.Font
      .Bold = True
      .Italic = True
   End With
   With Selection.Find
      .Text = strField
      .Replacement.Text = strField ''"\l ""current view only"
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
 
   Set Curdoc = Nothing
    ActiveWindow.ActivePane.View.ShowAll = False
End Sub