Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 09-04-2019, 07:07 AM
subrota subrota is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately Office 2013
Novice
How can I find my synonyms separately
 
Join Date: Apr 2019
Posts: 11
subrota is on a distinguished road
Default How can I find my synonyms separately

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
Attached Files
File Type: docm new-synonyms.docm (20.8 KB, 6 views)
Reply With Quote
  #2  
Old 09-04-2019, 08:30 AM
gmaxey gmaxey is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately 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

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #3  
Old 09-04-2019, 09:04 PM
subrota subrota is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately Office 2013
Novice
How can I find my synonyms separately
 
Join Date: Apr 2019
Posts: 11
subrota is on a distinguished road
Default

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
Reply With Quote
  #4  
Old 09-05-2019, 09:42 AM
gmaxey gmaxey is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately 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

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #5  
Old 09-05-2019, 08:35 PM
gmaxey gmaxey is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately 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

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #6  
Old 09-06-2019, 10:11 AM
gmaxey gmaxey is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately 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
  #7  
Old 09-07-2019, 11:12 PM
subrota subrota is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately Office 2013
Novice
How can I find my synonyms separately
 
Join Date: Apr 2019
Posts: 11
subrota is on a distinguished road
Default

Hey Greg Maxey
You have done a fantastic coding, these are beyond expectation.
Mind blowing!!!!
Thanks a lot.
Reply With Quote
  #8  
Old 09-08-2019, 06:16 AM
gmaxey gmaxey is offline How can I find my synonyms separately Windows 10 How can I find my synonyms separately 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

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/

Last edited by gmaxey; 09-08-2019 at 09:46 AM.
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
How to trigger animations separately ? mj2000 PowerPoint 0 02-06-2019 10:10 AM
How can I find my synonyms separately 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
How can I find my synonyms separately Useless synonyms & other spell check complaints Vervaine Word 1 12-18-2016 06:37 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:52 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft