#1
|
|||
|
|||
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 |
#2
|
|||
|
|||
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 |
#3
|
|||
|
|||
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 |
#4
|
|||
|
|||
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 |
#5
|
|||
|
|||
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 |
#6
|
|||
|
|||
... 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 |
#7
|
|||
|
|||
Hey Greg Maxey
You have done a fantastic coding, these are beyond expectation. Mind blowing!!!! Thanks a lot. |
#8
|
|||
|
|||
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 Last edited by gmaxey; 09-08-2019 at 09:46 AM. |
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 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 |