View Single Post
 
Old 09-06-2019, 10:11 AM
gmaxey gmaxey is offline Windows 10 Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,422
gmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the rough
Default

... this has been an interesting distraction. With a SortedList and some more detailed coding, we can sort the output and return synonyms for all the various meanings:


Code:
Option Explicit
Sub ListSynonyms()
Dim oSynInfo As SynonymInfo
Dim varList As Variant, varCList As Variant
Dim lngindex As Long, lngSyn As Long
Dim strSyns As String
Dim oDoc As Document, oDocReport As Document
Dim oRng As Range
Dim arrList() As String
Dim arrML
Dim oSortedList As Object
Dim oKey
  Set oSortedList = CreateObject("System.Collections.SortedList")
  Application.ScreenUpdating = False
  Set oDoc = ActiveDocument
  Set oDocReport = Documents.Add
  Set oRng = oDoc.Range
  arrList = Split("layout|Content|many|Various|sometimes|use", "|")
  Set oRng = oDoc.Range
  With oRng.Find
    .Font.Bold = True
    While .Execute
      Set oSynInfo = oRng.SynonymInfo
      If oSynInfo.MeaningCount > 0 Then
        If Not oSortedList.ContainsKey(oRng.Text) Then
          ReDim arrML(1 To UBound(oSynInfo.MeaningList), 1)
          For lngindex = 1 To UBound(arrML, 1)
            arrML(lngindex, 0) = "(" & lngindex & ". - " & fcnPartOfSpeech(oSynInfo.PartOfSpeechList(1)) & ")"
            arrML(lngindex, 1) = oSynInfo.SynonymList(lngindex)
          Next lngindex
          strSyns = vbNullString
          Select Case UBound(arrML, 1)
            Case 1
              varList = arrML(1, 1)
              strSyns = arrML(1, 0) & " "
              Select Case UBound(varList)
                Case 1
                  strSyns = strSyns & varList(0) & "."
                Case 2
                  strSyns = strSyns & varList(0) & " and " & varList(1) & "."
                Case Else
                  For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
                    Select Case lngSyn
                      Case Is = 1: strSyns = strSyns & varList(lngSyn)
                      Case UBound(oSynInfo.SynonymList(1)): strSyns = strSyns & " and " & varList(lngSyn) & "."
                      Case Else: strSyns = strSyns & ", " & varList(lngSyn)
                    End Select
                  Next lngSyn
              End Select
            Case Else
              For lngindex = 1 To UBound(arrML, 1)
                varList = arrML(lngindex, 1)
                If lngindex = 1 Then
                  strSyns = arrML(lngindex, 0) & " "
                Else
                  strSyns = strSyns & " " & ChrW(8212) & " " & arrML(lngindex, 0) & " "
                End If
                Select Case UBound(varList)
                  Case 1
                    strSyns = strSyns & varList(0) & "."
                  Case 2
                    strSyns = strSyns & varList(0) & " and " & varList(1) & "."
                  Case Else
                    For lngSyn = 1 To UBound(oSynInfo.SynonymList(lngindex))
                      Select Case lngSyn
                        Case Is = 1: strSyns = strSyns & varList(lngSyn)
                        Case UBound(oSynInfo.SynonymList(lngindex)): strSyns = strSyns & " and " & varList(lngSyn) & "."
                        Case Else: strSyns = strSyns & ", " & varList(lngSyn)
                      End Select
                    Next lngSyn
                End Select
              Next lngindex
          End Select
          oSortedList.Add oRng.Text, strSyns
          oRng.Collapse wdCollapseEnd
        End If
      End If
    Wend
  End With
  With oDocReport
    For lngindex = 0 To oSortedList.Count - 1
      Set oRng = .Range
      With oRng
        .Collapse wdCollapseEnd
        .Text = oSortedList.getKey(lngindex)
        .Font.Bold = True
        .Collapse wdCollapseEnd
        .InsertAfter " - " & oSortedList.getbyIndex(lngindex) & vbCr
        .Font.Bold = False
        .Paragraphs.Last.SpaceAfter = 12
      End With
    Next lngindex
    .Paragraphs.Last.Range.Delete
    .Activate
  End With
  Application.ScreenUpdating = True
  Set oRng = Nothing: Set oSortedList = Nothing
  Set oDoc = Nothing: Set oDocReport = Nothing
lbl_Exit:
  Exit Sub
End Sub

Function fcnPartOfSpeech(lngPOS) As String
  Select Case lngPOS
    Case 0: fcnPartOfSpeech = "Adjective"
    Case 1: fcnPartOfSpeech = "Noun"
    Case 2: fcnPartOfSpeech = "Adverb"
    Case 3: fcnPartOfSpeech = "verb"
    Case 4: fcnPartOfSpeech = "Pronoun"
    Case 5: fcnPartOfSpeech = "Conjuction"
    Case 6: fcnPartOfSpeech = "Preposition"
    Case 7: fcnPartOfSpeech = "Interjection"
    Case 8: fcnPartOfSpeech = "Idiom"
    Case 9: fcnPartOfSpeech = "Other"
  End Select
lbl_Exit:
  Exit Function
End Function
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote