Option
Explicit
Sub
Test_AllInOne()
Dim
rngWord
As
Word.Range
Dim
rngLaengste
As
Word.Range
Dim
dic
As
Object
Dim
nGrossb
As
Long
ThisDocument.Range.Font.Reset
ThisDocument.Range.HighlightColorIndex = wdAuto
Set
dic = CreateObject(
"Scripting.Dictionary"
)
dic.CompareMode = VbCompareMethod.vbBinaryCompare
For
Each
rngWord
In
ThisDocument.Words
rngWord.MoveEndWhile
" "
, wdBackward
If
IsWord(rngWord.Text)
Then
nGrossb = nGrossb + AnzGrossbuchstaben(rngWord.Text)
If
rngLaengste
Is
Nothing
Then
Set
rngLaengste = rngWord
ElseIf
Len(rngWord.Text) > Len(rngLaengste.Text)
Then
Set
rngLaengste = rngWord
End
If
If
Not
dic.Exists(rngWord.Text)
Then
Call
dic.Add(rngWord.Text, CreateObject(
"Scripting.Dictionary"
))
With
dic(rngWord.Text)
Call
.Add(.Count, rngWord)
End
With
Else
With
dic(rngWord.Text)
Call
.Add(.Count, rngWord)
End
With
End
If
End
If
Next
Call
MsgBox(
"Anzahl Großbuchstaben: "
& nGrossb, vbInformation)
With
rngLaengste
.HighlightColorIndex = WdColorIndex.wdRed
.Font.ColorIndex = WdColorIndex.wdWhite
End
With
Dim
vntElem
As
Variant
Dim
strKey
As
String
Dim
n
As
Long
For
Each
vntElem
In
dic
If
dic(vntElem).Count > n
Then
n = dic(vntElem).Count
strKey = vntElem
End
If
Next
If
strKey <>
""
Then
With
dic(strKey)
For
Each
vntElem
In
.Items()
vntElem.HighlightColorIndex = WdColorIndex.wdGreen
vntElem.Font.ColorIndex = WdColorIndex.wdWhite
Next
End
With
End
If
End
Sub
Private
Function
IsWord(Word
As
String
)
As
Boolean
Dim
blnFlag
As
Boolean
Dim
strChr
As
String
* 1
Dim
i
As
Long
blnFlag =
True
For
i = 1
To
Len(Word)
strChr = Mid$(Word, i, 1)
Select
Case
LCase$(strChr)
Case
"a"
To
"z"
,
"ä"
,
"ö"
,
"ü"
,
"ß"
Case
Else
blnFlag =
False
Exit
For
End
Select
Next
IsWord = blnFlag
End
Function
Private
Function
AnzGrossbuchstaben(Wort
As
String
)
As
Long
Dim
strChr
As
String
* 1
Dim
i
As
Long
Dim
n
As
Long
For
i = 1
To
Len(Wort)
strChr = Mid$(Wort, i, 1)
Select
Case
strChr
Case
"A"
To
"Z"
,
"Ä"
,
"Ö"
,
"Ü"
n = n + 1
End
Select
Next
AnzGrossbuchstaben = n
End
Function