'
' Diese Word-Routine erstellt eine Worthäufigkeitsstatistik' des aktiven Dokumentes.
' Erstellet am 08/03/99 von René Probst / eku / CH-8058-Glattbrugg
'
Option Compare Text
Private asTitle As String
Private asVisible As Boolean
Private oDoc As Document
Private sDoc As Document
Private wDoc As Document
Private oBlase As Balloon
Private Wahl As Integer
Private SortFeld As Integer
Private SortOrder As Integer
Private strWork As String
Private Stat()
Private TotWort As Double
Private AnzWort As Integer
Private LangWort As Integer
Private TotLänge As Double
Private Zähler As Integer
Sub Worthäufigkeit()
LangWort = 0
TotLänge = 0
TotWort = 0
asVisible = Assistant.Visible
asTitle = "Häufigkeit der Wörter"
Set oDoc = ActiveDocument
If oDoc.Content = Chr(13) Then WortKeineWörter
Assistant.Visible = True
Assistant.Animation = msoAnimationAppear
Wahl = BlaseAnzeigen
Select Case Wahl
Case 1, 2
SortFeld = Wahl
If oBlase.Checkboxes(1).Checked = True Then
SortOrder = wdSortOrderDescending
Else
SortOrder = wdSortOrderAscending
End If
Case -2
HappyEnd
End Select
If oDoc.Words.Count > 8191 Then
ReDim Stat(8191, 1)
Else
ReDim Stat(oDoc.Words.Count, 1)
End If
Zähler = -1
Assistant.Animation = msoAnimationWritingNotingSomething
For Each oWort In ActiveDocument.Words
If Left(UCase(oWort), 1) Like "[A-Zäöüàâéèêîïôû]" Then WortAufnehmen oWort
Next
strWork = ""
AnzWort = Zähler + 1
If AnzWort > 0 Then
WortAuflisten
WortTabelle
WortDokEinrichten
WortZusammenfassung
Else
WortKeineWörter
End If
HappyEnd
End Sub
Private Sub WortAufnehmen(tWort)
TotWort = TotWort + 1
tWort = RTrim(tWort)
ofs = InStr(tWort, "-")
While ofs > 0
tWort = Left(tWort, ofs - 1) + Right(tWort, Len(tWort) - ofs)
ofs = InStr(tWort, "-")
Wend
TotLänge = TotLänge + Len(tWort)
If Len(tWort) > LangWort Then LangWort = Len(tWort)
chk = InStr(strWork, Chr(1) + tWort + Chr(2))
If chk = 0 Then
StatusBar = CStr(TotWort) + " Wörter verarbeitet - " + CStr(Zähler + 1) + " Wörter aufgenommen...bitte warten."
DoEvents
Zähler = Zähler + 1
strWork = strWork + Chr(1) + tWort + Chr(2) + Format(Zähler, "0000")
Stat(Zähler, 0) = tWort
Stat(Zähler, 1) = 1
Else
ofs = InStr(chk, strWork, Chr(2))
j = Mid(strWork, ofs + 1, 4)
Stat(j, 1) = Stat(j, 1) + 1
End If
End Sub
Private Sub WortAuflisten()
Documents.Add
ActiveWindow.View = wdNormalView
Assistant.Animation = msoAnimationWorkingAtSomething
StatusBar = "Die Liste der Wörter wird erstellt."
DoEvents
Set wDoc = ActiveDocument
Application.ScreenUpdating = False
Selection.TypeText Text:="Wort" + vbTab + "Hits" + vbCrLf
For j = 0 To AnzWort - 1
Selection.TypeText Text:=Stat(j, 0) + vbTab + CStr(Stat(j, 1)) + vbCrLf
Next j
ReDim Stat(0, 0)
End Sub
Private Sub WortTabelle()
Assistant.Animation = msoAnimationGetTechy
StatusBar = "Die Liste der Wörter wird sortiertt."
DoEvents
With Selection
.WholeStory
.ConvertToTable Separator:=wdSeparateByTabs, Format:=wdTableFormatProfessional, AutoFit:=True
Dim oTable As Table
Set oTable = wDoc.Tables(1)
If AnzWort > 1 Then
Select Case SortFeld
Case 1
oTable.Sort ExcludeHeader:=True, _
FieldNumber:="Spalte1", SortFieldType:=0, SortOrder:=SortOrder
Case 2
oTable.Sort ExcludeHeader:=True, _
FieldNumber:="Spalte2", SortFieldType:=1, SortOrder:=SortOrder, _
FieldNumber2:="Spalte1", SortFieldType2:=0, SortOrder2:=0
End Select
End If
oTable.Rows(1).HeadingFormat = True
oTable.Columns(2).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Cells(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
oTable.Select
End With
End Sub
Private Sub WortDokEinrichten()
Assistant.Animation = msoAnimationGetArtsy
Documents.Add
ActiveWindow.View = wdNormalView
StatusBar = "Die Statistik wird erstellt."
DoEvents
Set sDoc = ActiveDocument
Selection.Style = "Überschrift 1"
Selection.TypeText Text:="Häufigkeit der Wörter in " + oDoc.Name
Selection.TypeParagraph
Set sKZ = sDoc.Sections(1).Headers(1).Range
sDoc.Fields.Add Range:=sKZ, Type:=wdFieldEmpty, Text:="FVREF ""Überschrift 1"""
sDoc.Sections(1).Footers(1).Range.Select
With Selection
.InsertAfter "Seite "
.EndKey
.Fields.Add Range:=Selection.Range, Type:=wdFieldPage
.EndKey
.InsertAfter " von "
.EndKey
.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="ANZSEITEN "
.ParagraphFormat.Alignment = wdAlignParagraphRight
End With
ActiveWindow.ActivePane.Close
End Sub
Private Sub WortZusammenfassung()
Häufigkeit = Format(TotWort / AnzWort, "0")
Durchschnitt = Format(TotLänge / TotWort, "0")
With Selection
.TypeText Text:="Anzahl Wörter:" + vbTab + CStr(TotWort) + Chr(11)
.TypeText Text:="Anzahl Einträge:" + vbTab + CStr(AnzWort) + Chr(11)
.TypeText Text:="Durchschnittliche Häufigkeit:" + vbTab + CStr(Häufigkeit) + Chr(11)
.TypeText Text:="Längstes Wort:" + vbTab + CStr(LangWort) + Chr(11)
.TypeText Text:="Durchschnittliche Wortlänge:" + vbTab + Durchschnitt
With .ParagraphFormat
.Style = "Standard"
.TabStops.Add CentimetersToPoints(6), Alignment:=wdAlignTabRight
.SpaceBefore = 6
.SpaceAfter = 18
End With
.TypeParagraph
.Range.FormattedText = wDoc.Content
End With
End Sub
Private Sub HappyEnd()
If Wahl > 0 And AnzWort > 0 Then
wDoc.Close SaveChanges:=wdDoNotSaveChanges
sDoc.Activate
Selection.HomeKey Unit:=wdStory
End If
Assistant.Visible = asVisible
StatusBar = ""
Application.ScreenUpdating = True
End
End Sub
Private Sub WortKeineWörter()
Antwort = MsgBox("Dieses Dokument enthält keine Wörter.", vbCritical, asTitle)
HappyEnd
End Sub
Private Function BlaseAnzeigen()
Set oBlase = Assistant.NewBalloon
With oBlase
.Mode = msoModeModal
.BalloonType = msoBalloonTypeButtons
.Icon = msoIconTip
.Heading = asTitle
asText = "Diese Routine erstellt eine Worthäufigkeitstatistik des aktiven Documentes."
.Text = asText + vbCrLf + vbCrLf + "Was möchten Sie tun ?"
.Labels(1).Text = "Eine alphabetische Liste der Wö
