Option
Explicit
Sub
Test()
Dim
rngWord
As
Word.Range
Dim
dic
As
Object
Dim
k
As
Long
Dim
k_min
As
Long
Dim
k_max
As
Long
Set
dic = CreateObject(
"Scripting.Dictionary"
)
ThisDocument.Range.Font.Reset
ThisDocument.Range.HighlightColorIndex = wdAuto
Debug.Print
"WORT"
; Tab(25);
"ANZ"
; Tab(30);
"POS"
For
Each
rngWord
In
ThisDocument.Words
rngWord.MoveEndWhile
" "
, wdBackward
k = Complexness(rngWord)
If
k > 0
Then
If
k < k_min
Or
k_min = 0
Then
k_min = k
If
k > k_max
Or
k_max = 0
Then
k_max = k
If
Not
dic.Exists(k)
Then
Call
dic.Add(k, rngWord)
Debug.Print
"'"
; rngWord.Text;
"'"
; Tab(25); k; Tab(30); rngWord.Start
End
If
End
If
Next
With
dic(k_min)
.HighlightColorIndex = WdColorIndex.wdGreen
.Font.ColorIndex = WdColorIndex.wdWhite
End
With
With
dic(k_max)
.HighlightColorIndex = WdColorIndex.wdRed
.Font.ColorIndex = WdColorIndex.wdWhite
End
With
End
Sub
Private
Function
Complexness(Word
As
Word.Range)
As
Long
Dim
rngChr
As
Word.Range
Dim
dic
As
Object
Set
dic = CreateObject(
"Scripting.Dictionary"
)
dic.CompareMode = VbCompareMethod.vbBinaryCompare
For
Each
rngChr
In
Word.Characters
Select
Case
rngChr.Text
Case
"a"
To
"z"
,
"A"
To
"Z"
,
"ä"
,
"ö"
,
"ü"
,
"ß"
dic(rngChr.Text) = dic(rngChr.Text) + 1
End
Select
Next
Complexness = dic.Count
End
Function