頭字語リストの自動作成（Microsoft Word）

http://www.ShaunaKelly.com/word/glossary/glossary.html

{ XE "abbrev (this is the definition)" }

Sub Send_2_acronym_list()

With ActiveDocument.Bookmarks         .Add Range:=Selection.Range, Name:="xxxHERExxx"

.DefaultSorting = wdSortByName         .ShowHidden = True     End With     Selection.Copy     Selection.EndKey Unit:=wdStory     Selection.TypeParagraph     Selection.PasteAndFormat (wdPasteDefault)

Selection.GoTo What:=wdGoToBookmark, Name:="xxxHERExxx"

Application.Run MacroName:="Normal.MoreNewMacros.EditGoTo"

Selection.MoveRight Unit:=wdCharacter, Count:=1 End Sub

Sub ListAcronyms()

Dim strAcronym As String     Dim strDefine As String     Dim strOutput As String     Dim newDoc As Document

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]>"

.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

'Look for definition             Selection.MoveRight Unit:=wdWord             Selection.MoveRight Unit:=wdCharacter, _               Extend:=wdExtend             strDefine = ""

If Selection.Text = "(" Then                 While Selection <> ")"

strDefine = strDefine & Selection.Text                     Selection.Collapse Direction:=wdCollapseEnd                     Selection.MoveRight Unit:=wdCharacter, _                       Extend:=wdExtend                 Wend             End If             Selection.Collapse Direction:=wdCollapseEnd             If Left(strDefine, 1) = "(" Then                 strDefine = Mid(strDefine, 2, Len(strDefine))

End If             If strDefine > "" Then                 'Check if the search result is in the Output string                 'if it is, ignore the search result                 If InStr(strOutput, strAcronym) = 0 Then                     strOutput = strOutput & strAcronym _                       & vbTab & strDefine & vbCr                 End If             End If         End If     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