title image


Smiley Wortkombinationen automatisch einfärben
Hallo!



Probier mal dies aus.



Viele Grüße!









Option Explicit



Const constStrTitel = "Finde gleiche Wortkombinationen"



Dim strGefunden As String





Sub Aufruf_FindeGleicheWortkombinationen()



Dim intAnzahlWorteErweiterung As Integer





' Inits

strGefunden = "Analyse für " & ActiveDocument.FullName & _

" am " & Now & "." & _

vbCr & vbCr



' Schleife

For intAnzahlWorteErweiterung = 3 To 2 Step -1

FindeGleicheWortkombinationen intAnzahlWorteErweiterung

Next



' Abschluss

Documents.Add

Selection.TypeText strGefunden



MsgBox "Fertig.", vbInformation, constStrTitel



End Sub



Private Sub FindeGleicheWortkombinationen(intAnzahlWorteErweiterung As Integer)



' 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



Application.StatusBar = wordMyWord

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(Replace(strSuchwort, ",", "")) > 3 Then



intWortanzahl = WortAnzahl(strSuchwort)



If funcStringEnthaelt(strSuchwort, vbCr) = False And _

funcStringEnthaelt(strSuchwort, vbLf) = False And _

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

funcStringEnthaelt(strGefunden, 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(Antwort) As Integer



' Wortanzahl ermitteln



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



Dim oRange As Range

Dim Anz As Long





Application.ScreenUpdating = False



Anz = 0

WortAnzahl = Anz



If Antwort = "" Then Exit Function



Set oRange = Selection.Range

ActiveDocument.Range(0, 0).Select

With Selection.Find

.ClearFormatting

.Text = Antwort

.Execute

While .Found = True

Anz = Anz + 1

.Execute

Wend

End With

oRange.Select

Application.ScreenUpdating = True



WortAnzahl = Anz



End Function



Sub FarbeFuerGewisseTextstellenVeraendern(Text, colorFarbe)



' Farbe Fuer Gewisse Textstellen Veraendern



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



Application.ScreenUpdating = False



With ActiveDocument.Range.Find

.Text = Text

.MatchCase = True

.MatchWholeWord = True

.Format = True

' .Replacement.Font.Italic = True

.Replacement.Font.Color = colorFarbe

.Execute Replace:=wdReplaceAll

End With



Application.ScreenUpdating = True



End Sub



Function funcStringEnthaelt(strWort, strGesucht) As Boolean



' Ist strGesucht in strWort enthalten?



If Len(strWort) Len(Replace(strWort, strGesucht, "")) Then

funcStringEnthaelt = True

Else

funcStringEnthaelt = False

End If



End Function



' Anderes ********************************************



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



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: