How can I find my synonyms separately

subrota · #1 09-04-2019, 07:07 AM

Hi,

I have a paragraph and some bold word (targeted word).
I need synonym for each targeted word in a new document.

Example My Paragraph:
It is a long established fact that a reader will be distracted by the readable content of a page when looking at its layout. The point of using Lorem Ipsum is that it has a more-or-less normal distribution of letters, as opposed to using Content here, content here', making it look like readable English. Many desktop publishing packages and web page editors now use Lorem Ipsum as their default model text, and a search for 'lorem ipsum' will uncover many web sites still in their infancy. Various versions have evolved over the years, sometimes by accident, sometimes on purpose (injected humour and the like).

Here my targeted words are:
layout, Content, us, many, Various, sometime

My expected outcome in a new document:
layout plan design arrangement outline draught draft blueprint
Content Gratified Happy Satisfied Contented Pleased Comfortable Relaxed At ease
........
.......

Code:

Dim mySynObj As Object
Dim Slist As Variant
Dim i As Long
Dim StrOut As String


Documents.Add
Windows(2).Activate
Selection.WholeStory
Selection.Find.Font.Bold = True

Do While Selection.Find.Execute
Selection.Copy

Set mySynObj = Selection.Range.SynonymInfo
Slist = mySynObj.SynonymList(1)
For i = 1 To UBound(mySynObj.SynonymList(1))
StrOut = StrOut & " " & Slist(i)
Next
Windows(1).Activate
Selection.Paste
Selection.TypeText Text:=StrOut
Selection.TypeParagraph
Windows(2).Activate
Loop

gmaxey · #2 09-04-2019, 08:30 AM

Code:

Sub ExtractSynonyms()
Dim oSynInfo As Object
Dim varList 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
  
  Set oDoc = ActiveDocument
  Set oDocReport = Documents.Add
  Set oRng = oDoc.Range
  arrList = Split("layout|Content|many|Various|sometimes|use", "|")
  For lngIndex = 0 To UBound(arrList)
    Set oRng = oDoc.Range
    With oRng.Find
      .Text = arrList(lngIndex)
      .Font.Bold = True
      .MatchCase = True
      If .Execute Then
        strSyns = arrList(lngIndex) & " - "
        Set oSynInfo = oRng.SynonymInfo
        varList = oSynInfo.SynonymList(1)
        For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
          strSyns = strSyns & " " & varList(lngSyn)
        Next
        oRng.Collapse wdCollapseEnd
        oDocReport.Range.InsertAfter strSyns & vbCr & vbCr
      End If
    End With
  Next lngIndex
  oDocReport.Activate
lbl_Exit:
  Exit Sub
End Sub

subrota · #3 09-04-2019, 09:04 PM

Greg Maxey,
Thank you for your cooperation.
Actually I need only the bold word's (bold word can be changed) synonym.
But in your code I can find only some specific bold word according my example paragraph.
If I add new bold word and make regular previous bold word then it show only that you have included in the code.

Thank you again
subrota

gmaxey · #4 09-05-2019, 09:42 AM

Code:

Sub ExtractSynonyms()
Dim oSynInfo As Object
Dim varList 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 oDic As Object
  Set oDic = CreateObject("Scripting.Dictionary")
  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
      If Not oDic.Exists(oRng.Text) Then
        oDic.Add oRng.Text, oRng.Text
        strSyns = oRng.Text & " - "
        Set oSynInfo = oRng.SynonymInfo
        varList = oSynInfo.SynonymList(1)
        For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
          strSyns = strSyns & " " & varList(lngSyn)
        Next
        oRng.Collapse wdCollapseEnd
        oDocReport.Range.InsertAfter strSyns & vbCr & vbCr
      End If
    Wend
  End With
  oDocReport.Activate
  Set oRng = Nothing: Set oDic = Nothing
lbl_Exit:
  Exit Sub
End Sub

gmaxey · #5 09-05-2019, 08:35 PM

You can add a little polish to the output by leveraging the fact that a dictionary key and be a range object:

Code:

Sub ListSynonyms()
Dim oSynInfo As Object
Dim varList 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 oDic As Object
Dim oKey
  Set oDic = CreateObject("Scripting.Dictionary")
  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
      If Not oDic.Exists(oRng.Text) Then
        Set oSynInfo = oRng.SynonymInfo
        varList = oSynInfo.SynonymList(1)
        Select Case UBound(oSynInfo.SynonymList(1))
          Case 0
            strSyns = varList(0) & "."
          Case 1
            strSyns = varList(0) & " and " & varList(1) & "."
          Case Else
            For lngSyn = 1 To UBound(oSynInfo.SynonymList(1))
              Select Case lngSyn
                Case Is = 1: strSyns = varList(lngSyn)
                Case UBound(oSynInfo.SynonymList(1)): strSyns = strSyns & " and " & varList(lngSyn) & "."
                Case Else: strSyns = strSyns & ", " & varList(lngSyn)
              End Select
            Next
        End Select
        oDic.Add oRng.FormattedText, strSyns
        oRng.Collapse wdCollapseEnd
      End If
    Wend
  End With
  With oDocReport
    For Each oKey In oDic
      Set oRng = .Range
      With oRng
        .Collapse wdCollapseEnd
        .FormattedText = oKey
        .Collapse wdCollapseEnd
        .InsertAfter " - " & oDic.Item(oKey) & vbCr
        .Font.Bold = False
        .Paragraphs.Last.SpaceAfter = 12
      End With
    Next oKey
    .Paragraphs.Last.Range.Delete
    .Activate
  End With
  Application.ScreenUpdating = True
  Set oRng = Nothing: Set oDic = Nothing
lbl_Exit:
  Exit Sub
End Sub

gmaxey · #6 09-06-2019, 10:11 AM

... 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

subrota · #7 09-07-2019, 11:12 PM

Hey Greg Maxey
You have done a fantastic coding, these are beyond expectation.
Mind blowing!!!!
Thanks a lot.

gmaxey · #8 09-08-2019, 06:16 AM

Thanks. Was just tinkering and found it interesting. Change:
arrML(lngindex, 0) = "(" & lngindex & ". - " & fcnPartOfSpeech(oSynInfo.PartOfSpeechList(1)) & ")"
To
arrML(lngindex, 0) = "(" & lngindex & ". - " & fcnPartOfSpeech(oSynInfo.PartOfSpeechList(lngIndex )) & ")"

Code:

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 arrML
Dim oSortedList As Object
  Set oSortedList = CreateObject("System.Collections.SortedList")
  Application.ScreenUpdating = False
  Set oDoc = ActiveDocument
  Set oDocReport = Documents.Add
  Set oRng = oDoc.Range
  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 & Chr(126) & fcnPartOfSpeech(oSynInfo.PartOfSpeechList(lngindex)) & ")"
            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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to trigger animations separately ?	mj2000	PowerPoint	0	02-06-2019 10:10 AM
How to write chapters separately with corresponding heading numbering	bluejasmine	Word	3	07-15-2018 07:21 AM
Check for value in each cell separately	Jelmer	Excel	4	07-06-2017 07:43 AM
Can we buy Access separately?	eeaakkat	Office	2	04-04-2017 08:28 PM
Useless synonyms & other spell check complaints	Vervaine	Word	1	12-18-2016 06:37 PM