Wenn man nur Nomen ausgeben möchte, dann muss man eine leichte Änderung am Code vornehmen, da in meinem letzten Codeschnipsel For-Each zum Einsatz kommt, wir aber auf eine Zählschleife zugreifen müssen (wir brauchen den Index von vntMeaning für die POS, diesen haben aber wegen der For-Each-Schleife nicht) - siehe unten.
Es gäbe noch eine andere Möglichkeit das zu lösen, ich würde es aber hierbei belassen wollen. ;) Mir liegt hier gerade mehr daran, dass du erkennst, dass mitunter der verwendete Schleifen-Typ wichtig/relevant sein kann.
Option Explicit
Sub Test()
'Verweis auf Word hinzufügen
' * VBA-Editor Menü 'Extras' -> 'Verweise...' -> Microsoft Word X.0 Object Library
Dim objWord As Word.Application
Dim objSynInfo As Word.SynonymInfo
Dim rngCell As Excel.Range
Dim vntMeaning As Variant
Dim vntSyn As Variant
Dim bolFlag As Boolean
Dim lngOffset As Long
Dim i As Long
'neue Word-Instanz erstellen
Set objWord = New Word.Application
'jede Zelle in der aktuellen Auswahl einzeln behandeln
For Each rngCell In Selection.Cells
'Thesarus/Synonyme für das Wort in der Zelle suchen
Set objSynInfo = objWord.SynonymInfo(rngCell.Text, wdGerman)
'für das aktuelle Wort kann es mehrere Bedeutungen geben
'(z.B. für 'Gut' als Substantiv -> 'Anwesen', Bauernhof, ...; oder als Adjektiv -> die gut[en] Sitten)
lngOffset = 1
' For Each vntMeaning In objSynInfo.MeaningList
For i = 1 To objSynInfo.MeaningCount
vntMeaning = objSynInfo.MeaningList(i)
'Was haben wir für eine Bedeutungen vorliegen? - Nomen, Adverb, Verb, ...
Select Case objSynInfo.PartOfSpeechList(i)
Case WdPartOfSpeech.wdNoun ', WdPartOfSpeech.wdAdverb, ...
bolFlag = True 'Flag/Schalter: EIN
Case Else
bolFlag = False 'Flag/Schalter: AUS
End Select
'Synonyme nur hinzufügen wenn Bedeutungs-Flag/-Schalter auf EIN steht
If bolFlag = True Then
'hier werden nun Synonyme unter der jeweiligen Bedeutung gesucht
'(z.B. 'Gut' mit der Bedeutung von z.B. 'Anwesen')
For Each vntSyn In objSynInfo.SynonymList(vntMeaning)
'spaltenweise - in der selben Zeile - ausgeben
rngCell.Offset(, lngOffset).Value = vntSyn
lngOffset = lngOffset + 1
Next
End If
Next
Next
'Word-Instanz schließen
objWord.Quit False
End Sub
Grüße
|