Sub PartsOfSpeech()
Dim wdSynInfo As SynonymInfo, wdSynList As Variant, i As Long, w As Long
Dim wdSyn As String, StrWrd As String, StrTmp As String, StrOut As String
With ActiveDocument.Range
  For w = 1 To .Words.Count
    StrTmp = "": StrWrd = Trim(.Words(w))
    If StrWrd Like "[A-Za-z]*" Then
      Set wdSynInfo = SynonymInfo(Word:=StrWrd, LanguageID:=wdEnglishUS)
      If wdSynInfo.MeaningCount <> 0 Then
        wdSynList = wdSynInfo.PartOfSpeechList
        For i = 1 To UBound(wdSynList)
          Select Case wdSynList(i)
            Case wdAdjective: wdSyn = "adjective"
            Case wdNoun: wdSyn = "noun"
            Case wdAdverb: wdSyn = "adverb"
            Case wdVerb: wdSyn = "verb"
            Case wdConjunction: wdSyn = "conjunction"
            Case wdIdiom: wdSyn = "idiom"
            Case wdInterjection: wdSyn = "interjection"
            Case wdPreposition: wdSyn = "preposition"
            Case wdPronoun: wdSyn = "pronoun"
            Case Else: wdSyn = "other"
          End Select
          If UBound(Split(StrTmp, " ")) < 1 Then
            StrTmp = StrTmp & " " & wdSyn
          ElseIf Split(StrTmp, " ")(UBound(Split(StrTmp, " "))) <> wdSyn Then
            StrTmp = StrTmp & " " & wdSyn
          End If
        Next i
        StrOut = StrOut & vbCr & StrWrd & ": " & Replace(Trim(StrTmp), " ", ", ")
      Else
        StrOut = StrOut & vbCr & StrWrd & ": No meanings found."
      End If
    End If
  Next w
End With
MsgBox StrOut
End Sub