Word

Acroynm Finder - easily find the meaning of acroynms in long documents.

Ease of Use

Intermediate

Version tested with

2016 

Submitted by:

supergrass71

Description:

Use this suite of macros to avoid navigating back and forth to the table of acronyms (usually located at the front or back of the document). I created this after dealing with 400+ page documents with 6 pages of acronyms (really!). 

Discussion:

Two main uses: 1. As a reader of a document, find an acronym's meaning by double clicking on it and firing the "createNote" macro. I add it to my Quick Access Toolbar. The macro displays the meaning in a message box. It then adds a bookmark at the acronym location and with the meaning as the description. This makes it work like a tooltip. 2. As the creator of a document, use it to check that you have included all acronyms in your acronym table. The macro will automatically append a list of missing acronyms to the end of the missing document. There is one prerequisite: your document needs a table somewhere in it of the form acronym | description (actual headings not important) TLA | Three Letter Acronym VIP | Very Important Person KBA | Knowledge Base Article ... etc When first using you will need to place your cursor somewhere in this table (don't select any particular text). The macro will create a reference document called reference_yourDocumentName in your My Documents/Documents directory (depending on your version of Windows. This document is your reference table and will be opened automatically whenever you call the createNote macro. Care has been taken to make the usage as error-free as possible. The only scenario the user has to care about is when an acronym is plural e.g. KBAs. In this case, you need to manually select 'KBA' as double click would select 'KBAs'. Note: a trailing space is dealt with by the macro. The code appears long but I have it saved in three separate modules. It has been used in both my home and work environment with no changes. It does use some global variables, but these are unlikely to clash with your existing code. 

Code:

instructions for use 

			
Option Explicit 
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 
 
 
 
Sub createNote() 
     'based on https://wordribbon.tips.net/T013230_ScreenTips_without_Hyperlinks
     'uses acronym module instead of user inputbox
    Dim timeStamp As String, bookmarkName As String, screentipText As String, key As String 
    Dim rng As Range 
    Dim answer As Integer 
    Dim tbl As Table 
    Application.ScreenUpdating = False 
    timeStamp = Format(Now(), "yyyyMMddHHmmss") 
     'On Error GoTo ErrHandler
     'establish lookup table (runs longer first time!)
    Set lookupDocument = Nothing 
    Call createAcronymTableFile 
     
     'adjust lookup string of selected text accordingly (selection may or may not have a trailing space)
    Select Case Right(fcnGetCellText(lookupDocument.Tables(1).Cell(1, 1)), 1) 'top left reference cell
    Case Is = Chr(32) 'trailing space
        If Right(Selection.Text, 1) = Chr(32) Then 
            key = Selection.Text 'includes trailing space
            Selection.MoveEnd Unit:=wdCharacter, Count:=-1 
        Else 
            key = Selection.Text & Chr(32) 
        End If 
    Case Else 
        If Right(Selection.Text, 1) = Chr(32) Then 
            Selection.MoveEnd Unit:=wdCharacter, Count:=-1 
            key = Selection.Text 'includes trailing space
        Else 
            key = Selection.Text 
        End If 
    End Select 
    Set rng = Selection.Range 
     'this prevents bookmark error when initially setting up the reference table
    If Selection.Information(wdWithInTable) Then 
        If Selection.Cells.Count > 1 Then Exit Sub 'multiple cells were selected
    End If 
    screentipText = acronymDescription(key, lookupDocument.Tables(1)) 
     'On Error GoTo 0
    If screentipText = "Value not found" Then 
         
        MsgBox screentipText 
        Exit Sub 
    End If 
     'assign name of bookmark
    bookmarkName = rng.Text & "_" & timeStamp 
     'check for bad bookmark names & correct if necessary [replaced Selection.Text with rng.Text 20190725]
    If Not InStr(1, rng.Text, "-", vbTextCompare) = 0 Then 'contains "-"
        bookmarkName = Replace(rng.Text, "-", "", vbTextCompare) & "_" & timeStamp 
    End If 
    If Not InStr(1, Selection.Text, "&", vbTextCompare) = 0 Then 'contains "&"
        bookmarkName = Replace(rng.Text, "&", "", vbTextCompare) & "_" & timeStamp 
    End If 
     'add bookmark
    With ActiveDocument.Bookmarks 
        .Add Range:=rng, Name:=bookmarkName 'was Selection.rng
        .DefaultSorting = wdSortByName 
        .ShowHidden = False 
    End With 
     'add hyperlink & screentip [todo: if possible, find adjacent cell to glossary term in table, use to pre-populate tip input]
    rng.Select 'restore focus to sending text
    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _ 
    SubAddress:=bookmarkName, ScreenTip:=screentipText, TextToDisplay:= _ 
    Selection.Text 
     'remove hyperlink formatting
    rng.Select 
    With Selection.Font 
        .ColorIndex = wdAuto 
        .Underline = wdUnderlineNone 
    End With 
    MsgBox screentipText 
    Set lookupDocument = Nothing 
    Application.ScreenUpdating = True 
CreateNoteErrHandler: 
End Sub 
Sub addScreenTip(doc As Document, rng As Range, bmark As String, tip As String) 
     'add bookmark
    With doc.Bookmarks 
        .Add Range:=Selection.Range, Name:=bmark 
        .DefaultSorting = wdSortByName 
        .ShowHidden = False 
    End With 
     
End Sub 
Function ReplaceInTable(textToFind As String) As String 
     'http://www.msofficeforums.com/word-vba/28049-vba-table-search-all-tables-find-replace.html
    Dim oRng As Range 
    Set oRng = ActiveDocument.Range 
     'if used as sub add inputbox for texttofind
    With oRng.Find 
        Do While .Execute(FindText:=textToFind) 
            If oRng.Information(wdWithInTable) Then 
                oRng.Select 
                Selection.Cells(1).Next.Select 
                Set oRng = Selection.Range 
                 
                ReplaceInTable = CleanTrim(oRng.Text, True) 
                GoTo lbl_Exit 
            End If 
        Loop 
    End With 
lbl_Exit: 
     'ReplaceInTable = "" 'could not find a reference table
    Exit Function 
End Function 
Function CleanTrim(ByVal S As String, Optional ConvertNonBreakingSpace As Boolean = True) As String 
     'https://www.mrexcel.com/forum/excel-questions/923725-vba-remove-all-non-printable-special-characters-well-trim.html
    Dim X As Long, CodesToClean As Variant 
    CodesToClean = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _ 
    21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 127, 129, 141, 143, 144, 157) 
    If ConvertNonBreakingSpace Then S = Replace(S, Chr(160), " ") 
    For X = LBound(CodesToClean) To UBound(CodesToClean) 
        If InStr(S, Chr(CodesToClean(X))) Then S = Replace(S, Chr(CodesToClean(X)), "") 
    Next 
    CleanTrim = S 
End Function 
 
Private Type SHITEMID 
    cb As Long 
    abID As Byte 
End Type 
Private Type ITEMIDLIST 
    mkid As SHITEMID 
End Type 
Private Const CSIDL_PERSONAL As Long = &H5 
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _ 
(ByVal hwndOwner As Long, ByVal nFolder As Long, _ 
pidl As ITEMIDLIST) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ 
(ByVal pidl As Long, ByVal pszPath As String) As Long 
Public Function Rep_Documents() As String 
    Dim lRet As Long, IDL As ITEMIDLIST, sPath As String 
    lRet = SHGetSpecialFolderLocation(100&, CSIDL_PERSONAL, IDL) 
    If lRet = 0 Then 
        sPath = String$(512, Chr$(0)) 
        lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) 
        Rep_Documents = Left$(sPath, InStr(sPath, Chr$(0)) - 1) 
    Else 
        Rep_Documents = vbNullString 
    End If 
End Function

How to use:

  1. [First Use] Open your Word document.
  2. Place your cursor in the table containing the acronyms. If these are in tabbed format you might be able to use convert text to table.
  3. Run the macro CreateNote. In newer versions of Word, this is located in the Developer Tab.
  4. [Following uses]Locate an acronym in your document that you want to check the meaning of and select it (double left click).
  5. Run the createNote macro. The meaning of the acronym will be displayed. Any acronyms with missing definitions will be recorded in the reference document.
 

Test the code:

 

Sample File:

No Attachment 

Approved by Jacob Hilderbrand


This entry has been viewed 7 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express