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

Comments

Popular posts from this blog

Revit area plans adding new types and references (Gross and rentable)

Organization and management of data in Revit across omniclass, Masterformat, Uniclass, and Uniformat