Sub ListAcronyms()
'
' ListAcronyms Macro
' Macro created 6/9/2009 by vk830c
'
'The macro looks through the document for anything it thinks might be an acronym (All CAPS).
'It then looks for the definition.  It assumes the following format: Test Work Description (TWD)
'Once the macro is finished going through the document, it creates a new document,
'adds the acronyms there, and then sorts them all.  If an Acronym isn't defined on the first
'go around, it should still be in the list without a definition.
'Note this macro will find ALL capitalized words whether they are words or acronyms.
'If you are looking through a document that has tracking changes on, I would recommend accepting
'all the changes before running the macro as sometimes the comments/changes have a hidden character that
'causes the macro to stop.
'I would also add the word ZDEBUG at the very end of the file, then run the macro
'In this manner you can verify that the macro made it through the entire document
'before giving you output.  If it doesn't make through the end of the document the most likely
'cause is a hidden character and I haven't figured out a work around for that.
'I would recommend deleting the current acronym list in a document before running this macro
'if you want to verify that all the acronyms are in the document.
'Note - this macro will not find embedded acronyms in pictures.
'DEBUG Notes - add the word ZDEBUG in the document to find out where the macro is crashing.  Select DebugFound variable.
'Then select Debug--> Add Watch and have it Break when value changes.  Also open View--> Immediate window to see the
'debug statements.  This will allow the Macro to stop whenever it finds the words DEBUG.
    
    
    Dim strAcronym As String
    Dim strTest As String
    Dim strDefine As String
    Dim strOutput As String
    Dim AcronymDefined As Boolean
    Dim DebugFound As Boolean
    
    
    Dim newDoc As Document
    
    Dim length As Integer
    Dim i As Integer
    
    Application.ScreenUpdating = False
    Selection.HomeKey unit:=wdStory
    ActiveWindow.View.ShowHiddenText = False
   'Loop to find all acronyms
    Do
        'Search for acronyms using wildcards
        Selection.Find.ClearFormatting
        With Selection.Find
            .ClearFormatting
           ' .Text = "<[A-Z]@[A-Z,1-9]@[A-Z,1-9]>"
            .Text = "<[A-Z]@[A-Z,1-9]>"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            .MatchWholeWord = True
            .Execute
        End With
        
        'Only process if something found
        If Selection.Find.Found Then
            'Make a string from the selection, add it to the output string
            strAcronym = " " & Selection.Text & " "
            length = Len(strAcronym) - 2
            AcronymDefined = False
            If InStr(strAcronym, "DEBUG") <> 0 Then
                Debug.Print "the length of the strOutput = " & Len(strOutput)
                DebugFound = True
            End If
                        
            'Look for definition
            Selection.MoveRight unit:=wdCharacter, Extend:=wdExtend
            strTest = Selection.Text
            If Right(strTest, 1) = ")" Then
                ' acronym is in parenthesis
                AcronymDefined = True
                
                ' find beginning "("
                Selection.MoveLeft unit:=wdCharacter, Count:=length + 2, Extend:=wdExtend
                strTest = Selection.Text 'debug statement
                Selection.MoveLeft unit:=wdWord, Count:=length, Extend:=wdExtend
                strTest = Selection.Text
                strTest = Mid(strTest, 1, Len(strTest) - 1)
             End If
            strDefine = ""
            If Not AcronymDefined Then
                strTest = ""
            End If
            If InStr(strOutput, strAcronym) = 0 Then
                 Debug.Print "Adding"; strAcronym
                 strOutput = strOutput & strAcronym _
                 & vbTab & strTest & vbCr
            End If
        End If
        ' now move ahead of acronym
        If AcronymDefined Then
            Selection.MoveRight unit:=wdWord, Count:=length
            Debug.Print "Acronym was defined, move forward one word"
        End If
        If Not AcronymDefined Then
            Selection.MoveRight unit:=wdCharacter, Count:=1
            Debug.Print "Acronym was NOT defined, move forward one character"
        End If
        If length = 0 Then
            'might be in an infinite loop
            'skip ahead a word
            Selection.MoveRight unit:=wdWord, Count:=5
        End If
        DebugFound = False
        
        Loop Until Not Selection.Find.Found
        'Create new document and change active document
    Set newDoc = Documents.Add
    'Insert the text
    Selection.TypeText Text:=strOutput
    'Sort it
    newDoc.Content.Sort SortOrder:=wdSortOrderAscending
    Application.ScreenUpdating = True
    Selection.HomeKey unit:=wdStory
    
End Sub