Option Explicit
Private Type myWorteStatistik_structure
s_Wort As String
l_cnt As Long
End Type
'Einstellungen für die Wortstatistik
Private Const c_GROSSKLEINSCHREIBUNG_BEACHTEN As Boolean = False
Private Const c_WORT_MIMIMAL_LAENGE = 2
Private Const c_BINDESTRICHERSATZ = xxyyzzbbbzzyyxx
'Einstellungen für die Satz-Komplexitaet - Komma
Private Const cMAXKOMMAANZAHL = 20-> in einem Satz
Sub StatistikWortSatzBuchstabe()
->Es wird das aktive Dokument bearbeitet
->Der Kontent wird satzweise eingelesen, da dies die größte Einheit ist.
->
->Statistik über:
->- Gesamtanzahl Sätze
Dim lGesAnz_Satz As Long
->- Gesamtanzahl Wörter
Dim lGesAnz_Wort As Long
->- Komplexität Mittelwert Wörter pro Satz
Dim dMittelwertWoerterProSatz As Double
->- Komplexität nach Anzahl der Kommata in den Sätzen
Dim kk(0 To cMAXKOMMAANZAHL) As Long
->- Liste der Wörter und Anzahl deren Vorkommens
Dim w() As myWorteStatistik_structure, w_cnt As Long
->- Buchstaben-Häufigkeit im Text
Dim b() As Long: ReDim b(33 To 255)
Dim doc As Document, doc_tmp As Document, r As Range
Dim lStart As Long, lEnd As Long, lEndLast As Long, lAnz As Long
Dim sTxt As String
->Application.ScreenUpdating = False
Set doc = ActiveDocument
Set r = doc.Content
lStart = r.Start
lEndLast = r.End
->über alle Sätze
lGesAnz_Satz = r.Sentences.Count
If lGesAnz_Satz < 2 Then MsgBox Leeres Dokument oder nur ein Satz.: GoTo AUFRAEUMEN
lGesAnz_Satz = 0
->tempoäres Dokument anlegen
Set doc_tmp = Documents.Add
->über alle Sätze
doc.Content.Select
Selection.Collapse Direction:=wdCollapseStart
Selection.Expand Unit:=wdSentence
lStart = Selection.Start
lEnd = Selection.Start
Do
->Markierung in einer Tabelle ?
If Selection.Tables.Count > 0 Then
->Endemarke oder Zeile in Tabelle markiert ?
If Selection.Cells.Count = 0 Then GoTo NAECHSTE
End If
->markierten Text holen
sTxt = Selection.Text
->ist vor der letzten Endemarke etwas selektiert,
->was bereits vorher selektiert/ausgewertet wurde ?
->(kommt in der Tabelle vor)
If Selection.Start < lStart Then
->dann vom Text abschneiden
lAnz = lStart - Selection.Start
sTxt = Right(sTxt, Len(sTxt) - lAnz)
End If
Call StringBereinigenVonSteuerzeichen(sTxt)
If sTxt = Then GoTo NAECHSTE
lGesAnz_Satz = lGesAnz_Satz + 1
Call ZeichenStatistik(sTxt, b())
Call KommasStatistik(sTxt, kk())
NAECHSTE:
->war das der letzte Satz ? dann Ende der Untersuchung
If Selection.End = r.End Then Exit Do
->einen Satz weiterschalten
lStart = Selection.End
Selection.Collapse Direction:=wdCollapseEnd
Selection.Expand Unit:=wdSentence
lEnd = Selection.End
Loop
Call StatistikWorte(doc, w(), w_cnt, lGesAnz_Wort, doc_tmp)
->- Komplexität Mittelwert Wörter pro Satz
dMittelwertWoerterProSatz = lGesAnz_Wort / lGesAnz_Satz
doc_tmp.Content.Text = Untersuchte Datei: & doc.FullName & vbCrLf & vbCrLf
Call StatistikAusgabe(doc_tmp, lGesAnz_Satz, b(), kk())
Call Ausgabe_StatistikWorte(w(), w_cnt, lGesAnz_Wort, doc_tmp)
AUFRAEUMEN:
Application.ScreenUpdating = True
Set doc_tmp = Nothing: Set doc = Nothing: Set r = Nothing
End Sub
'*******************************************************************
Private Function StringBereinigenVonSteuerzeichen(sTxt As String)
Dim sTmp As String, s As String, x As Long
For x = 1 To Len(sTxt)
s = Mid(sTxt, x, 1)
If Asc(s) > 31 Then sTmp = sTmp & s
Next
sTxt = Trim(sTmp)
End Function
'*******************************************************************
Private Function ZeichenStatistik(sTxt As String, b() As Long)
Dim s As String, x As Long, lAsc As Long
For x = 1 To Len(sTxt)
s = Mid(sTxt, x, 1)
lAsc = Asc(s)
If lAsc > 32 Then b(lAsc) = b(lAsc) + 1
Next
End Function
'*******************************************************************
Private Function StatistikAusgabe(doc As Document, lGesAnz_Satz As Long, b() As Long, kk() As Long)
Dim t As Table
Dim x As Long, lAnz As Long, lStart As Long, lEnd As Long
doc.Content.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertAfter vbCrLf & vbCrLf
Selection.Collapse Direction:=wdCollapseEnd
lStart = Selection.Start
Selection.InsertAfter Gesamtanzahl Sätze: & lGesAnz_Satz & vbCrLf & vbCrLf
lEnd = Selection.End
Selection.Start = lStart
Selection.End = lEnd
Selection.Range.Bold = True
doc.Content.Select
Selection.Collapse Direction:=wdCollapseEnd
lStart = Selection.Start
Selection.InsertAfter Statistik - Kommas pro Satz & vbCrLf & vbCrLf
lEnd = Selection.End
Selection.Start = lStart
Selection.End = lEnd
Selection.Range.Bold = True
Selection.Range.Underline = True
Selection.Collapse Direction:=wdCollapseEnd
lAnz = 0
For x = UBound(kk()) To 0
If kk(x) > 0 Then lAnz = x: Exit For
Next
Set t = doc.Tables.Add(Selection.Range, lAnz + 2, 2, wdWord9TableBehavior, wdAutoFitContent)
t.Cell(1, 1).Range.Text = Anzahl Kommas im Satz
t.Cell(1, 1).Range.Bold = True
t.Cell(1, 2).Range.Text = Anzahl Sätze
t.Cell(1, 2).Range.Bold = True
For x = 0 To lAnz
t.Cell(2 + x, 1).Range.Text = x
t.Cell(2 + x, 2).Range.Text = kk(x)
Next
doc.Content.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertAfter vbCrLf & vbCrLf
Selection.Collapse Direction:=wdCollapseEnd
lStart = Selection.Start
Selection.InsertAfter Buchstaben-Statistik & vbCrLf & vbCrLf
lEnd = Selection.End
Selection.Start = lStart
Selection.End = lEnd
Selection.Range.Bold = True
Selection.Range.Underline = True
Selection.Collapse Direction:=wdCollapseEnd
For x = LBound(b()) To UBound(b())
If b(x) > 0 Then lAnz = lAnz + 1
Next
Set t = doc.Tables.Add(Selection.Range, lAnz + 1, 2, wdWord9TableBehavior, wdAutoFitContent)
t.Cell(1, 1).Range.Text = Buchstabe
t.Cell(1, 1).Range.Bold = True
t.Cell(1, 2).Range.Text = Anzahl Auftreten
t.Cell(1, 2).Range.Bold = True
lAnz = 0
For x = LBound(b()) To UBound(b())
If b(x) > 0 Then
lAnz = lAnz + 1
t.Cell(1 + lAnz, 1).Range.Text = Chr(x)
t.Cell(1 + lAnz, 2).Range.Text = b(x)
End If
Next
AUFRAEUMEN:
Set t = Nothing
End Function
'************************************************************
Private Function StatistikWorte(doc_org As Document, _
f() As myWorteStatistik_structure, f_cnt As Long, _
lGesAnz_Wort As Long, doc_tmp As Document)
'************************************************************
' Zählt die Worte des aktiven Dokuments.
' Erzeugt ein temporäres Dokument und gibt darauf ein Tabelle
' mit den Spalten->Wort' und Häufigkeit aus
'
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' !!! geschützter Bindestrich und Bindestrich werden vor der Zählung durch
' !!! c_BINDESTRICHERSATZ ersetzt, da Word diese sonst als zwei Worte betrachtet.
' !!! Nach der Zählung wird diese Ersetzung wieder korrigiert
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim myword As Range
Dim s_Wort As String
Dim l_Anz As Long, l_ind As Long, x As Long, pos As Long
->erstmal eine Text-Kopie vom Original anlegen -> keine Tabellen mehr
doc_tmp.Content.Text = doc_org.Content.Text
->Statistik initialisieren
ReDim f(1 To 100): f_cnt = 0
->im Dokument alle Steuerzeichen durch Leerzeichen ersetzen
Call SteuerZeichenDurchLeerzeichenErsetzen(doc_tmp.Content)
->alle Worte abarbeiten
For Each myword In doc_tmp.Words
s_Wort = myword.Text
s_Wort = Trim(s_Wort)
->Minimallänge ?
If Len(s_Wort) < c_WORT_MIMIMAL_LAENGE Then GoTo NAECHSTESWORT
->GroßKleinschreibung beachten ?
If Not c_GROSSKLEINSCHREIBUNG_BEACHTEN Then s_Wort = LCase(s_Wort)
->Wort suchen
l_ind = 0
For x = 1 To f_cnt
If s_Wort = f(x).s_Wort Then l_ind = x: Exit For
Next
->Wort schon vorhanden
If l_ind > 0 Then
->schon vorhanden -> Zähler erhöhen
f(l_ind).l_cnt = f(l_ind).l_cnt + 1
Else
->nicht vorhanden -> neu anlegen
f_cnt = f_cnt + 1
If UBound(f()) < f_cnt Then ReDim Preserve f(1 To f_cnt + 100)
f(f_cnt).l_cnt = 1: f(f_cnt).s_Wort = s_Wort
End If
NAECHSTESWORT:
Next
lGesAnz_Wort = 0
For x = 1 To f_cnt
s_Wort = f(x).s_Wort
Do
pos = InStr(1, s_Wort, c_BINDESTRICHERSATZ)
If pos = 0 Then Exit Do
->BINDESTRICHERSATZ durchBindestrich ersetzen
s_Wort = Left(s_Wort, pos - 1) & Chr(30) & _
Right(s_Wort, Len(s_Wort) - pos + 1 - Len(c_BINDESTRICHERSATZ))
Loop
f(x).s_Wort = s_Wort
lGesAnz_Wort = lGesAnz_Wort + f(x).l_cnt
Next
AUFRAEUMEN:
Set myword = Nothing
End Function
'************************************************************
Private Function Ausgabe_StatistikWorte(f() As myWorteStatistik_structure, f_cnt As Long, _
lGesAnz_Wort As Long, doc_tmp As Document)
'************************************************************
' Gibt am Ende des Dokumentes ein Tabelle mit den Spalten->Wort' und Häufigkeit aus
Dim mytab As Table
Dim s_Wort As String
Dim l_Anz As Long, lStart As Long, lEnd As Long, x As Long
doc_tmp.Content.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertAfter vbCrLf & vbCrLf
Selection.Collapse Direction:=wdCollapseEnd
lStart = Selection.Start
Selection.InsertAfter Gesamtanzahl Worte: & lGesAnz_Wort & vbCrLf & vbCrLf
lEnd = Selection.End
Selection.Start = lStart
Selection.End = lEnd
Selection.Range.Bold = True
Selection.Collapse Direction:=wdCollapseEnd
lStart = Selection.Start
Selection.InsertAfter Wort-Statistik & vbCrLf & vbCrLf
lEnd = Selection.End
Selection.Start = lStart
Selection.End = lEnd
Selection.Range.Bold = True
Selection.Range.Underline = True
Selection.Collapse Direction:=wdCollapseEnd
->Tabelle einfügen
Set mytab = doc_tmp.Tables.Add(Selection.Range, f_cnt + 1, 2, wdWord9TableBehavior, wdAutoFitContent)
With mytab.Cell(1, 1).Range: .Text = Wort: .Bold = True: End With
With mytab.Cell(1, 2).Range: .Text = Anzahl: .Bold = True: End With
For x = 1 To f_cnt
s_Wort = f(x).s_Wort
mytab.Cell(x + 1, 1).Range.Text = s_Wort
mytab.Cell(x + 1, 2).Range.Text = f(x).l_cnt
Next
->Tabelle sortieren
mytab.Sort _
ExcludeHeader:=True, _
FieldNumber:=1, _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending, _
CaseSensitive:=c_GROSSKLEINSCHREIBUNG_BEACHTEN
AUFRAEUMEN:
Set mytab = Nothing
End Function
Private Function SteuerZeichenDurchLeerzeichenErsetzen(r As Range)
Dim x As Long
Call myErsetzen(r, Chr(30), c_BINDESTRICHERSATZ) ->geschützter Bindestrich -> c_BINDESTRICHERSATZ
Call myErsetzen(r, Chr(45), c_BINDESTRICHERSATZ) ->Bindestrich -> c_BINDESTRICHERSATZ
->Steuerzeichen durch Leerzeichen ersetzen
For x = 1 To 30
Call myErsetzen(r, Chr(x), ) ->Steuerzeichen (1 -30) -> Leerzeichen
Next
Call myErsetzen(r, Chr(31), ) ->bedingter Trennstrich -> löschen
Call myErsetzen(r, Chr(151), ) ->Langer Gedankenstrich -> löschen
Call myErsetzen(r, Chr(150), ) ->Gedankenstrich -> löschen
Call myErsetzen(r, Chr(160), )->geschütztes Leerzeichen -> Leerzeichen
Call myErsetzen(r, Chr(182), )->Absatz -> Leerzeichen
Call myErsetzen(r, Chr(133), )->Auslasspunkte -> Leerzeichen
Call myErsetzen(r, Chr(145), )->einf. öffnendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(146), )->einf. schliessendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(147), )-> öffnendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(148), )-> schliessendes Anfz. -> Leerzeichen
For x = 10 To 2 Step -1
Call myErsetzen(r, String(x, ), )->doppelte Leerzeichen -> Leerzeichen
Next
End Function
Private Function myErsetzen(r As Range, s_Text As String, s_Ersetzen As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With r.Find
.Text = s_Text: .Replacement.Text = s_Ersetzen: .Wrap = wdFindContinue: .Format = False
End With
r.Find.Execute Replace:=wdReplaceAll
End Function
Private Function KommasStatistik(sTxtSatz As String, kk() As Long)
Dim lAnz As Long, pos As Long
lAnz = 0
pos = 0
Do
pos = InStr(pos + 1, sTxtSatz, ,)
If pos > 0 Then lAnz = lAnz + 1 Else Exit Do
Loop
If lAnz > cMAXKOMMAANZAHL Then lAnz = cMAXKOMMAANZAHL
kk(lAnz) = kk(lAnz) + 1
End Function
[br][br]