Acronym #Word

createAcronymTableFile.bas

Public referenceDocument As Document
Public lookupDocument As Document
Public activeDictionary As Object
Option Explicit
Sub createAcronymTableFile()
'#####################################################################################################
'#                                                                                                   #
'#      *  Take table of abbreviations from existing document and use it as a separate reference     #
'#      *  Takes ideas from a number of places                                                       #
'#      *                                                                                            #
'#      *                                                                                            #
'#      *                                                                                            #
'#      *                                                                                            #
'#      *                                                                                            #
'#                                                                                                   #
'#####################################################################################################
Dim newDocumentName As String, existingDocumentName As String, docNameWithoutExtension As String
Set referenceDocument = ActiveDocument
'superceded document naming method - simplified! 20190726
newDocumentName = "reference_" & Left(ActiveDocument.Name, InStr(1, ActiveDocument.Name, ".") - 1) 'to remove original *.doc or *.docx
If Right(newDocumentName, 1) = Chr(46) Then newDocumentName = Left(newDocumentName, Len(newDocumentName) - 1) 'remove extra period (if present)
'check for existence of reference file, if non-existent, create it
existingDocumentName = ""
On Error Resume Next
existingDocumentName = Dir(Rep_Documents() & "\" & newDocumentName & ".docx") 'check existence of document
Set lookupDocument = Documents.Open(Rep_Documents() & "\" & newDocumentName & ".docx")
On Error GoTo 0
'create document if it does not exist
If existingDocumentName = "" Then
    Call copyTableToNewDoc
    On Error GoTo ErrHandler
    lookupDocument.SaveAs (Rep_Documents() & "\" & newDocumentName & ".docx")
End If
'restore focus to "calling" document
referenceDocument.Activate
ErrHandler:
'If Err.Number = 5 Then GoTo CreateNoteErrHandler: [note: cannot refer to label in another sub, need to cascade errors refer to Chip Pearson]
End Sub
Sub copyTableToNewDoc()

Dim rng As Range, lookupRng As Range
Dim currentTableIndex As Index
Dim tbl As Table
Dim endOfDocument As Integer
'user must have cursor inside the reference table!
If Not Selection.Information(wdWithInTable) Then
    Err.Raise 5, , "You need to create the reference table first!" & vbLf _
            & "Please put cursor inside the table of acronymns or abbreviations" & vbLf _
            & "and run this macro again!"
    Exit Sub
End If
'create new document with selected table in it
Set lookupDocument = Documents.Add
'MsgBox referenceDocument.Name
referenceDocument.Activate
Selection.Tables(1).Range.Select
Selection.Copy
Set rng = lookupDocument.Range
rng.Collapse Direction:=wdCollapseEnd
rng.PasteSpecial DataType:=wdPasteRTF
lookupDocument.Tables(1).Rows(1).Delete
'move to end of document and add missing definitions section
rng.Collapse Direction:=wdCollapseEnd
rng.Text = "== Missing Definitions =="
'note: table MUST only contain one header row - is there a way to determine if the new row 1 contains 2 columns as a test condition
End Sub
Function acronymDescription(txt As String, tbl As Table) As String
Dim i As Integer, totalTableRows As Integer
Dim key As String
Dim value As String
Dim dict As Object
Dim rng As Range
If activeDictionary Is Nothing Then
    totalTableRows = tbl.Rows.Count
    'Set dict = GetPersistentDictionary()
    Set dict = CreateObject("Scripting.Dictionary")
    'build dictionary
    For i = 1 To totalTableRows
        key = fcnGetCellText(tbl.Cell(i, 1))
        value = fcnGetCellText(tbl.Cell(i, 2))
        'add new key/value
        If Not dict.Exists(key) Then
            dict.Add key, value
        End If
        If key = txt Then GoTo StopBuildingDictionary '[remove if dictionary persists
            'since we only need to create once]
    Next i
 
    
StopBuildingDictionary:
    'test with txt and return value
    If Not dict.Exists(txt) Then
        acronymDescription = "Value not found"
        Set rng = lookupDocument.Range
        rng.Collapse Direction:=wdCollapseEnd
        rng.Text = vbCr & txt
    Else
        acronymDescription = dict(txt)
    End If
    Set dict = activeDictionary 'for next search
Else
    If Not dict.Exists(txt) Then
        acronymDescription = "Value not found"
        Set rng = lookupDocument.Range
        rng.Collapse Direction:=wdCollapseEnd
        rng.Text = vbCr & txt
    Else
        acronymDescription = activeDictionary(txt)
    End If
End If
End Function
Function fcnGetCellText(ByRef oCell As Word.Cell) As String
'https://gregmaxey.com/word_tip_pages/vba_nuggets.html (Method 3)
'Replace the end of cell marker with a null string.
  fcnGetCellText = Replace(oCell.Range.Text, ChrW(13) & ChrW(7), vbNullString)
End Function