Microsoft Office Forums - View Single Post - [Solved] How to count words in a text, arrange them in separate lines and put the grammar class ?

macropod · 12-03-2018, 07:47 PM

Word is incapable of the context analysis needed to determine the part of speech for many words. For example, with your sample text, the following macro reports the potential parts of speech of most words - note the common exceptions!

Code:

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