Public Sub SpinArticle()

    Dim objSI As Word.SynonymInfo

    Dim strWord As String

    Dim strData As String

    Dim strResult As String

    Dim arrItems() As String

    Dim blnReplaced As Boolean

    Dim i As Integer

    Dim j As Integer

    Dim intMax As Integer

    Dim blnIsCap As Boolean

    Dim strTemp As String

    Dim strChar As String

    Dim lngNumWords As Long

    Dim strCap As String

    Dim strPunc As String



    RemoveTags



    strResult = ""

    strCap = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

    strPunc = ".!?,;"



    '* begin looping through every word in the ActiveDocument

    lngNumWords = ActiveDocument.Words.Count

    For j = 1 To lngNumWords

        strWord = Trim(ActiveDocument.Words(j))

        blnReplaced = False



        '* only worry about large words

        If Len(strWord) > 3 Then

            Set objSI = Word.SynonymInfo(strWord)



            '* check if the word is a NOUN or an ADJECTIVE

            If UBound(objSI.PartOfSpeechList) <> 0 Then

                'If objSI.PartOfSpeechList(1) = wdNoun Then

                If objSI.PartOfSpeechList(1) = wdAdjective Then



                    '* check is synonyms found

                    If objSI.Found = True Then



                        '* check for capitalization

                        strChar = Left(strWord, 1)

                        If InStr(strCap, strChar) > 0 Then

                            blnIsCap = True

                        Else

                            blnIsCap = False

                        End If



                        '* examine the list of synonyms and prepare { tags

                        arrItems = objSI.SynonymList(1)

                        'arrItems = objSI.RelatedWordList

                        If UBound(arrItems) <> 0 Then



                            strData = "{" & Trim(strWord)

                            intMax = UBound(arrItems)

                            If intMax > 3 Then intMax = 3

                            For i = 1 To intMax

                                strTemp = arrItems(i)

                                If blnIsCap Then

                                    strTemp = UCase(Left(strTemp, 1)) _

                                        & Right(strTemp, Len(strTemp) – 1)

                                End If

                                strData = strData & "|" & strTemp

                            Next i

                            strData = strData & "}"



                            '* confirm this replacement is good

                            If j > 3 And j < lngNumWords – 3 Then

                                strTemp = ActiveDocument.Words(j – 3) _

                                        & " " & ActiveDocument.Words(j – 2) _

                                        & " " & ActiveDocument.Words(j – 1) _

                                        & " " & Chr(34) & strWord & Chr(34) _

                                        & " " & ActiveDocument.Words(j + 1) _

                                        & " " & ActiveDocument.Words(j + 2) _

                                        & " " & ActiveDocument.Words(j + 3)

                            Else

                                strTemp = Chr(34) & strWord & Chr(34)

                            End If

                            'strTemp = InputBox("Change " & vbCrLf _

                                '& strTemp & vbCrLf & " to ", , strData)

                            'If StrPtr(strTemp) = 0 Then

                              '  '* user pressed cancel

                            'Else

                                blnReplaced = True

                                strResult = strResult & " " & strData

                            'End If

                        End If

                    End If

                End If

            End If

        End If



        '* if the word was not replace, add the original word to the result

        If blnReplaced = False Then

            If InStr(strPunc, strWord) > 0 Then

                strResult = strResult & strWord

            Else

                strResult = strResult & " " & strWord

            End If

        End If

    Next j



    ActiveDocument.Select

    Selection.Text = strResult



End Sub



Public Sub RemoveTags()

    Dim intStart As Integer

    Dim intEnd As Integer

    Dim strData As String

    Dim arrItems() As String



    '* move to the beginning of the document

    Selection.HomeKey Unit:=wdStory



    '* find the first { tag

    Selection.Start = 0

    With Selection.Find

        .Text = "{"

        .Replacement.Text = ""

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute



    '* begin looping while { tags are found

    While Selection.Start > 0

        intStart = Selection.Start



        '* locate the ending } tag

        With Selection.Find

            .Text = "}"

            .Replacement.Text = ""

            .Forward = True

            .Wrap = wdFindContinue

            .Format = False

            .MatchCase = False

            .MatchWholeWord = False

            .MatchWildcards = False

            .MatchSoundsLike = False

            .MatchAllWordForms = False

        End With

        Selection.Find.Execute



        intEnd = Selection.End



        '* adjust the selection to capture {…}

        Selection.Start = intStart

        Selection.End = intEnd

        Selection.Select



        RemoveSelectionTags



        '* locate the next { tag

        Selection.Start = 0

        With Selection.Find

            .Text = "{"

            .Replacement.Text = ""

            .Forward = True

            .Wrap = wdFindContinue

            .Format = False

            .MatchCase = False

            .MatchWholeWord = False

            .MatchWildcards = False

            .MatchSoundsLike = False

            .MatchAllWordForms = False

        End With

        Selection.Find.Execute



    '* continue the looping

    Wend

End Sub



Public Sub RemoveSelectionTags()

     Dim strData As String

     Dim arrItems() As String



     '* remove the { tags

     strData = Selection.Text

     strData = Replace(strData, "{", "")

     strData = Replace(strData, "}", "")



     '* split the alternates by the pipe delimiter

     '* use the first alternative

     arrItems = Split(strData, "|")

     strData = arrItems(0)



     Selection.Text = strData

End Sub