title image


Smiley Neue Version ohne Replace






Option Explicit



' Findet gleiche Wortkombinationen in einem

' Dokument.

' Verwendet eigene Private Function ReplaceMy statt

' replace, um für Word 97 kompatibel zu sein.

' Word 2000ff. user bitte ReplaceMy durch

' replace ersetzen.



Const constStrTitel = "Finde gleiche Wortkombinationen"



Dim strGefunden         As String





Sub Aufruf_FindeGleicheWortkombinationen()



    ' Die Verwendung dieser Aufrufsub ermöglicht es,

    ' die Anzahl der Worte, nach denen auf einmal gesucht

    ' wird (die Länge der Wortkombination) zu variieren.

    ' Sinnigerweise fängt man mit einer langen Kombination

    ' an (7) und wird von da aus kleiner (bis 2).

    ' Leider ist die Rechenzeit dann sehr lang, so dass

    ' 3 bis 2 gewählt wurde (step -1).

    ' Der Wert bestimmt die Anzahl der auf einmal untersuchten

    ' Worte.

    ' Es wird ein Wort mehr als angegeben untersucht (Bereich

    ' wird um intAnzahlWorteErweiterung erweitert).



    Dim intAnzahlWorteErweiterung   As Integer

    Dim docOldDoc                   As Document

    Dim docNewDoc                   As Document





    ' Inits

    ' Prüfungen, ggf. Abbruch

    If Documents.Count <= 0 Then End

    If ActiveDocument.Words.Count <= 0 Then End



    Application.ScreenUpdating = False



    ' Init für Text mit bisher gefundenen

    ' Wortkombinationen

    strGefunden = "Analyse für " & _

                  ActiveDocument.FullName & _

                  " am " & _

                  Format(Now, "d. mmmm yyyy") & _

                  ", um " & _

                  Format(Now, "hh:mm") & _

                  " Uhr." & _

                  vbCr & vbCr



    ' Init: Inhalt des Dokuments in ein neues

    ' Dokument sichern

    Set docOldDoc = ActiveDocument

    Set docNewDoc = Documents.Add

    docNewDoc.Range = docOldDoc.Range



    ' Schleife

    For intAnzahlWorteErweiterung = 3 To 2 Step -1

        Application.StatusBar = "Schleife mit " & _

                                intAnzahlWorteErweiterung & _

                                "."

        FindeGleicheWortkombinationen intAnzahlWorteErweiterung

    Next



    ' Abschluss

    Selection.TypeText strGefunden & vbCr & vbCr

    docNewDoc.Range.Paragraphs.Alignment = wdAlignParagraphLeft



    Application.ScreenUpdating = True



    MsgBox "Fertig.", _

           vbInformation, _

           constStrTitel



End Sub



Private Sub FindeGleicheWortkombinationen(intAnzahlWorteErweiterung As Integer)



    ' Eigentliche Hauptsub für das Finden gleicher

    ' Wortkombinationen.



    ' siehe auch Sentences (bisher nicht verwendet)



    Dim wordMyWord

    Dim rngMyRange          As Range

    Dim rngWord             As Range

    Dim arrayFarben()

    Dim intFarbIndex        As Integer

    Dim intUBoundVonArray   As Integer

    Dim intWortanzahl       As Integer

    Dim strSuchwort         As String

    Dim wordMyWord2





    ' Inits:

    arrayFarben = Array(wdColorBlue, wdColorRed, wdColorGreen, _

                        wdColorBrightGreen, wdColorYellow)



    intFarbIndex = 0

    intUBoundVonArray = UBound(arrayFarben)



    ' Schleife

    For Each wordMyWord In ActiveDocument.Words



        Set rngMyRange = ActiveDocument.Paragraphs(1).Range

        rngMyRange.SetRange Start:=wordMyWord.Start, End:=wordMyWord.End

        Set rngWord = rngMyRange

        ' Startzeichenposition des Bereichs:

        rngMyRange.Start = wordMyWord.Start

        ' Verschiebt die Endzeichenposition des Bereichs.

        ' Der Wert nach Count bestimmt die Anzahl der untersuchten Worte.

        ' Es wird ein Wort mehr als nach Count angegeben untersucht (Bereich

        ' wird um Count erweitert).

        rngMyRange.MoveEnd unit:=wdWord, _

                           Count:=intAnzahlWorteErweiterung



        strSuchwort = Trim(rngMyRange.Text)



        ' Einzelne Worte im Bereich einzeln analysieren

        For Each wordMyWord2 In rngMyRange.Words

            ' zu kurz? Zum Beispiel um Kommata, die als Wort

            ' auftauchen, abzulehnen.

            If Len(Trim(wordMyWord2)) < 2 Then

                strSuchwort = ""

                Exit For

            End If

        Next



        ' Analyse

        If Len(ReplaceMy(strSuchwort, ",", "")) > 3 Then



            intWortanzahl = WortAnzahl(strSuchwort)



            If funcStringEnthaelt(strSuchwort, vbCr) = False And _

               funcStringEnthaelt(strSuchwort, vbLf) = False And _

               funcStringEnthaelt(strSuchwort, Chr(11)) = False And _

               funcStringEnthaelt(UCase(strGefunden), UCase(strSuchwort)) = False And _

               intWortanzahl > 1 Then



                strGefunden = strGefunden & strSuchwort & " (" & intWortanzahl & ")" & vbCr

                FarbeFuerGewisseTextstellenVeraendern strSuchwort, arrayFarben(intFarbIndex)

                intFarbIndex = intFarbIndex + 1

                If intFarbIndex > intUBoundVonArray Then

                    intFarbIndex = 0

                End If



            End If



        End If



    Next



End Sub



' Hilfsprozeduren ********************************************



Function WortAnzahl(strText) As Integer



  ' Wortanzahl ermitteln (wie oft kommt

  ' ein Suchwort / Suchabschnitt im Dokument

  ' vor?)



  ' von http://mypage.bluewin.ch/reprobst/WordFAQ/Worth.htm#Worth1



  Dim longAnzahl           As Long





  longAnzahl = 0

  WortAnzahl = 0



  If strText = "" Then Exit Function



  With ActiveDocument.Range.Find

    .ClearFormatting

    .Text = strText

    .Execute

    While .Found = True

      longAnzahl = longAnzahl + 1

      .Execute

    Wend

  End With



  WortAnzahl = longAnzahl



End Function



Sub FarbeFuerGewisseTextstellenVeraendern(strText, colorFarbe)



  ' Farbe fuer gewisse Textstellen (Vorkommen "strText")

  ' zu Farbe "colorFarbe" veraendern.



  ' von http://mypage.bluewin.ch/reprobst/WordFAQ/Find.htm#Find11



  With ActiveDocument.Range.Find

    .Text = strText

    .MatchCase = False

    .MatchWholeWord = False

    .Format = False

    .Replacement.Font.Color = colorFarbe

    .Execute replace:=wdReplaceAll

  End With



End Sub



Sub TestOn_funcStringEnthaelt()

    MsgBox funcStringEnthaelt("Hallo", "lalo")

End Sub



Function funcStringEnthaelt(strWort, strGesucht) As Boolean



    ' Ist strGesucht in strWort enthalten?



    If InStr(1, strWort, strGesucht) > 0 Then

        funcStringEnthaelt = True

    Else

        funcStringEnthaelt = False

    End If



'    If Len(strWort) > Len(ReplaceMy(strWort, strGesucht, "")) Then

'        funcStringEnthaelt = True

'    Else

'        funcStringEnthaelt = False

'    End If



End Function



Private Function ReplaceMy(sText, _

                           vSuche As Variant, _

                           VErsetze As Variant) _

                              As String



    ' Für VB5 (Word 97):



    Dim I   As Integer

    Dim S   As String





    For I = 1 To Len(sText)



        ' S = Mid(sText, I, 1)

        S = Mid(sText, I, Len(vSuche))



        If S = vSuche Then

            ReplaceMy = ReplaceMy & VErsetze

        Else

            ReplaceMy = ReplaceMy & S

        End If



    Next I



End Function



' Anderes / Tests ********************************************



Sub TestOnAsciiWerteImDokument()



    Dim a1





    For Each a1 In ActiveDocument.Characters



        If MsgBox(a1 & "   " & Asc(a1), _

                  vbOKCancel + vbInformation, _

                  "Ascii-Werte zeigen") = vbCancel Then

            End

        End If



    Next



End Sub



Sub TestOn_Sentences()



    Dim sentenceMy





    For Each sentenceMy In ActiveDocument.Sentences

        MsgBox sentenceMy.Words(3) & "   " & sentenceMy.Words(3).End

    Next



End Sub







Code eingefügt mit Syntaxhighlighter 4.0





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: