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